diff --git a/CMakeLists.txt b/CMakeLists.txt index 3aab2f2c1..87c770258 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -2,8 +2,8 @@ cmake_minimum_required(VERSION 3.9) # set default build type cache entry (do so before project(...) is called, which would create this cache entry on its own) if(NOT CMAKE_BUILD_TYPE) - message(STATUS "setting default build type: Release") - set(CMAKE_BUILD_TYPE "Release" CACHE STRING "Choose the type of build, options are: None(CMAKE_CXX_FLAGS or CMAKE_C_FLAGS used) Debug Release RelWithDebInfo MinSizeRel.") + message(STATUS "setting default build type: Release") + set(CMAKE_BUILD_TYPE "Release" CACHE STRING "Choose the type of build, options are: None(CMAKE_CXX_FLAGS or CMAKE_C_FLAGS used) Debug Release RelWithDebInfo MinSizeRel.") endif() project(FESOM2.0) @@ -19,7 +19,7 @@ set(USE_ICEPACK OFF CACHE BOOL "compile fesom with the Iceapck modules for sea i set(OPENMP_REPRODUCIBLE OFF CACHE BOOL "serialize OpenMP loops that are critical for reproducible results") set(USE_MULTIO OFF CACHE BOOL "Use MULTIO for IO, either grib or binary for now. This also means path to MULTIO installation has to provided using env MULTIO_INSTALL_PATH='..' and multio configuration yamls must be present to run the model with MULTIO") set(OASIS_WITH_YAC OFF CACHE BOOL "Useing a version of OASIS compiled with YAC instead of SCRIP for interpolation?") - -#set(VERBOSE OFF CACHE BOOL "toggle debug output") +set(ASYNC_ICEBERGS ON CACHE BOOL "compile fesom with or without support for asynchronous iceberg computations") +set(VERBOSE OFF CACHE BOOL "toggle debug output") #add_subdirectory(oasis3-mct/lib/psmile) add_subdirectory(src) diff --git a/config/namelist.config b/config/namelist.config index ec665f53f..16402a01a 100644 --- a/config/namelist.config +++ b/config/namelist.config @@ -65,3 +65,11 @@ flag_debug=.false. n_levels=2 n_part= 12, 36 ! 432 number of partitions on each hierarchy level / + +&icebergs +use_icesheet_coupling=.false. +ib_num=1 +use_icebergs=.false. +steps_per_ib_step=8 +ib_async_mode=0 +/ diff --git a/config/namelist.forcing b/config/namelist.forcing index 53f4494d7..f6e82de01 100644 --- a/config/namelist.forcing +++ b/config/namelist.forcing @@ -23,6 +23,16 @@ ncar_bulk_z_shum=10.0 ! height at which humi forcing is located (CORE, JRA-do: 1 use_landice_water=.false. landice_start_mon=5 landice_end_mon=10 +fwf_path='./mesh/' + +/ + +&age_tracer +use_age_tracer=.false. +use_age_mask=.false. +age_tracer_path='./mesh/' +age_start_year=2000 + / &nam_sbc diff --git a/config/namelist.io b/config/namelist.io index 1e32cc8b4..8ad55dc10 100644 --- a/config/namelist.io +++ b/config/namelist.io @@ -13,7 +13,7 @@ ldiag_trflx =.false. / &nml_general -io_listsize =100 !number of streams to allocate. shallbe large or equal to the number of streams in &nml_list +io_listsize =120 !number of streams to allocate. shallbe large or equal to the number of streams in &nml_list vec_autorotate =.false. / @@ -50,4 +50,7 @@ io_list = 'sst ',1, 'm', 4, 'bolus_u ',1, 'y', 4, 'bolus_v ',1, 'y', 4, 'bolus_w ',1, 'y', 4, + 'icb ',1, 'm', 4, + 'fw ',1, 'm', 4, + 'fh ',1, 'm', 4, / diff --git a/env/levante.dkrz.de/shell b/env/levante.dkrz.de/shell index e863d83d3..f92a5ed96 120000 --- a/env/levante.dkrz.de/shell +++ b/env/levante.dkrz.de/shell @@ -1 +1 @@ -shell.intel \ No newline at end of file +shell.gnu \ No newline at end of file diff --git a/env/mistral.dkrz.de/shell-intel+openmpi b/env/mistral.dkrz.de/shell-intel+openmpi index d4227b601..ab9b3d09c 100644 --- a/env/mistral.dkrz.de/shell-intel+openmpi +++ b/env/mistral.dkrz.de/shell-intel+openmpi @@ -42,9 +42,5 @@ export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:${NETCDFFROOT}/lib:${HDF5ROOT}/lib:${NET export FESOM_USE_CPLNG='active' -export DR_HOOK=1 -export DR_HOOK_IGNORE_SIGNALS='-1' -export DR_HOOK_OPT=prof -export DR_HOOK_PROFILE_LIMIT=0.5 export OIFS_DUMMY_ACTION=ABORT export HDF5_DISABLE_VERSION_CHECK=1 diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 62049b853..7af2a9226 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -152,6 +152,9 @@ if(${FESOM_COUPLED}) endif() target_compile_definitions(${PROJECT_NAME} PRIVATE __oasis) endif() +if(${ASYNC_ICEBERGS}) + target_compile_definitions(${PROJECT_NAME} PRIVATE __async_icebergs) +endif() if(${OIFS_COUPLED}) target_compile_definitions(${PROJECT_NAME} PRIVATE __oifs) endif() diff --git a/src/MOD_DYN.F90 b/src/MOD_DYN.F90 index 3d7dab074..ee2819dcc 100644 --- a/src/MOD_DYN.F90 +++ b/src/MOD_DYN.F90 @@ -62,7 +62,11 @@ MODULE MOD_DYN ! sea surface height arrays real(kind=WP), allocatable, dimension(:) :: eta_n, d_eta, ssh_rhs, ssh_rhs_old - + + ! LA: 2023-05-17 iceberg arrays + real(kind=WP), allocatable, dimension(:) :: eta_n_ib ! kh 18.03.21 additional array for asynchronous iceberg computations + real(kind=WP), allocatable, dimension(:,:,:):: uv_ib ! kh 18.03.21 additional array for asynchronous iceberg computations + !___________________________________________________________________________ ! summarizes solver input parameter type(t_solverinfo) :: solverinfo diff --git a/src/MOD_ICE.F90 b/src/MOD_ICE.F90 index b2a91acd8..26bffe34a 100644 --- a/src/MOD_ICE.F90 +++ b/src/MOD_ICE.F90 @@ -49,6 +49,7 @@ MODULE MOD_ICE !___________________________________________________________________________ real(kind=WP) :: rhoair=1.3 , inv_rhoair=1./1.3 ! Air density & inverse , LY2004 !1.3 AOMIP real(kind=WP) :: rhowat=1025., inv_rhowat=1./1025.! Water density & inverse + real(kind=WP) :: rhofwt=1000., inv_rhofwt=1./1000.! Freshwter density & inverse real(kind=WP) :: rhoice=910. , inv_rhoice=1./910. ! Ice density & inverse, AOMIP real(kind=WP) :: rhosno=290. , inv_rhosno=1./290. ! Snow density & inverse, AOMIP ! Specific heat of air, ice, snow [J/(kg * K)] @@ -111,9 +112,9 @@ MODULE MOD_ICE !___________________________________________________________________________ ! zonal & merdional ice velocity - real(kind=WP), allocatable, dimension(:) :: uice, uice_rhs, uice_old, uice_aux - real(kind=WP), allocatable, dimension(:) :: vice, vice_rhs, vice_old, vice_aux - + real(kind=WP), allocatable, dimension(:) :: uice, uice_rhs, uice_old, uice_aux, uice_ib + real(kind=WP), allocatable, dimension(:) :: vice, vice_rhs, vice_old, vice_aux, vice_ib + ! surface stess atm<-->ice, oce<-->ice real(kind=WP), allocatable, dimension(:) :: stress_atmice_x, stress_iceoce_x real(kind=WP), allocatable, dimension(:) :: stress_atmice_y, stress_iceoce_y @@ -133,9 +134,17 @@ MODULE MOD_ICE ! total number of ice tracers (default=3, 1=area, 2=mice, 3=msnow, (4=ice_temp) #if defined (__oifs) || defined (__ifsinterface) integer :: num_itracers=4 +#else +! integer :: num_itracers=3 + !------------------------------ + ! LA 2023-01-31 add icebergs +#if defined(__async_icebergs) + integer :: num_itracers=5 #else integer :: num_itracers=3 -#endif +#endif + !------------------------------ +#endif ! put ice tracers data arrays type(t_ice_data), allocatable, dimension(:) :: data @@ -751,7 +760,9 @@ subroutine ice_init(ice, partit, mesh) ! to here since namelist.ice is now read in ice_init where whichEVP is not available ! when mesh_auxiliary_arrays is called !array of 2D boundary conditions is used in ice_maEVP - if (ice%whichEVP > 0) then + + ! LA 2023-05-24 initiate bc_index_nod2D also for whichEVP==0 + !if (ice%whichEVP > 0) then allocate(mesh%bc_index_nod2D(myDim_nod2D+eDim_nod2D)) mesh%bc_index_nod2D=1._WP do n=1, myDim_edge2D @@ -759,9 +770,9 @@ subroutine ice_init(ice, partit, mesh) if (myList_edge2D(n) <= mesh%edge2D_in) cycle mesh%bc_index_nod2D(ed)=0._WP end do - end if - -end subroutine ice_init + !end if + +end subroutine ice_init ! ! ! diff --git a/src/MOD_MESH.F90 b/src/MOD_MESH.F90 index 30c2b928f..2d458c732 100644 --- a/src/MOD_MESH.F90 +++ b/src/MOD_MESH.F90 @@ -118,11 +118,15 @@ MODULE MOD_MESH !_______________________________________________________________________________ ! Arrays added for ALE implementation: ! --> layer thinkness at node and depthlayer for t=n and t=n+1 +!------------------------------ real(kind=WP), allocatable,dimension(:,:) :: hnode real(kind=WP), allocatable,dimension(:,:) :: hnode_new real(kind=WP), allocatable,dimension(:,:) :: zbar_3d_n real(kind=WP), allocatable,dimension(:,:) :: Z_3d_n +! LA 2023-01-31 add icebergs +real(kind=WP), allocatable,dimension(:,:) :: Z_3d_n_ib +!------------------------------ ! --> layer thinkness at elements, interpolated from hnode real(kind=WP), allocatable,dimension(:,:) :: helem @@ -250,6 +254,7 @@ subroutine write_t_mesh(mesh, unit, iostat, iomsg) call write_bin_array(mesh%hnode_new, unit, iostat, iomsg) call write_bin_array(mesh%zbar_3d_n, unit, iostat, iomsg) call write_bin_array(mesh%Z_3d_n, unit, iostat, iomsg) + call write_bin_array(mesh%Z_3d_n_ib, unit, iostat, iomsg) call write_bin_array(mesh%helem, unit, iostat, iomsg) call write_bin_array(mesh%bottom_elem_thickness, unit, iostat, iomsg) call write_bin_array(mesh%bottom_node_thickness, unit, iostat, iomsg) @@ -346,6 +351,7 @@ subroutine read_t_mesh(mesh, unit, iostat, iomsg) call read_bin_array(mesh%hnode_new, unit, iostat, iomsg) call read_bin_array(mesh%zbar_3d_n, unit, iostat, iomsg) call read_bin_array(mesh%Z_3d_n, unit, iostat, iomsg) + call read_bin_array(mesh%Z_3d_n_ib, unit, iostat, iomsg) call read_bin_array(mesh%helem, unit, iostat, iomsg) call read_bin_array(mesh%bottom_elem_thickness, unit, iostat, iomsg) call read_bin_array(mesh%bottom_node_thickness, unit, iostat, iomsg) diff --git a/src/MOD_PARTIT.F90 b/src/MOD_PARTIT.F90 index 3a76761bf..08db5b5b4 100644 --- a/src/MOD_PARTIT.F90 +++ b/src/MOD_PARTIT.F90 @@ -33,11 +33,22 @@ module MOD_PARTIT end type com_struct TYPE T_PARTIT + + !--------------------------------------------------- + !LA 2023-01-31 add asynchronous icebergs + ! kh 10.02.21 communicator for async iceberg computations based on OpenMP + integer :: MPI_COMM_FESOM_IB + !--------------------------------------------------- type(com_struct) :: com_nod2D type(com_struct) :: com_elem2D type(com_struct) :: com_elem2D_full + !--------------------------------------------------- + !LA 2023-01-31 add asynchronous icebergs + ! kh 11.02.21 + integer :: MPIERR_IB + !--------------------------------------------------- integer :: npes integer :: mype integer :: maxPEnum=100 diff --git a/src/associate_mesh_ass.h b/src/associate_mesh_ass.h index e21a32faa..d2fa85123 100644 --- a/src/associate_mesh_ass.h +++ b/src/associate_mesh_ass.h @@ -54,6 +54,9 @@ hnode(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%hnode(:,:) hnode_new(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%hnode_new(:,:) zbar_3d_n(1:mesh%nl, 1:myDim_nod2D+eDim_nod2D) => mesh%zbar_3d_n(:,:) Z_3d_n(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%Z_3d_n(:,:) +#if defined(__async_icebergs) +Z_3d_n_ib(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%Z_3d_n_ib(:,:) +#endif helem(1:mesh%nl-1, 1:myDim_elem2D) => mesh%helem(:,:) bottom_elem_thickness(1:myDim_elem2D) => mesh%bottom_elem_thickness(:) bottom_node_thickness(1:myDim_nod2D+eDim_nod2D) => mesh%bottom_node_thickness(:) diff --git a/src/associate_mesh_def.h b/src/associate_mesh_def.h index c98af5a32..30482cabe 100644 --- a/src/associate_mesh_def.h +++ b/src/associate_mesh_def.h @@ -38,6 +38,7 @@ real(kind=WP), dimension(:,:), pointer :: hnode real(kind=WP), dimension(:,:), pointer :: hnode_new real(kind=WP), dimension(:,:), pointer :: zbar_3d_n real(kind=WP), dimension(:,:), pointer :: Z_3d_n +real(kind=WP), dimension(:,:), pointer :: Z_3d_n_ib real(kind=WP), dimension(:,:), pointer :: helem real(kind=WP), dimension(:) , pointer :: bottom_elem_thickness real(kind=WP), dimension(:) , pointer :: bottom_node_thickness diff --git a/src/associate_part_ass.h b/src/associate_part_ass.h index af53de8d2..d2ee2010d 100644 --- a/src/associate_part_ass.h +++ b/src/associate_part_ass.h @@ -1,4 +1,5 @@ MPI_COMM_FESOM => partit%MPI_COMM_FESOM +MPI_COMM_FESOM_IB => partit%MPI_COMM_FESOM_IB com_nod2D => partit%com_nod2D com_elem2D => partit%com_elem2D com_elem2D_full => partit%com_elem2D_full @@ -12,6 +13,7 @@ eDim_edge2D => partit%eDim_edge2D pe_status => partit%pe_status elem_full_flag => partit%elem_full_flag MPIERR => partit%MPIERR +MPIERR_IB => partit%MPIERR_IB npes => partit%npes mype => partit%mype maxPEnum => partit%maxPEnum diff --git a/src/associate_part_def.h b/src/associate_part_def.h index 0b0e23409..262780a4a 100644 --- a/src/associate_part_def.h +++ b/src/associate_part_def.h @@ -1,5 +1,5 @@ - - integer, pointer :: MPI_COMM_FESOM ! FESOM communicator (for ocean only runs if often a copy of MPI_COMM_WORLD) + integer, pointer :: MPI_COMM_FESOM ! FESOM communicator (for ocean only runs if often a copy of MPI_COMM_WORLD) + integer, pointer :: MPI_COMM_FESOM_IB ! FESOM communicator copy for icebergs LA: 2023-05-22 type(com_struct), pointer :: com_nod2D type(com_struct), pointer :: com_elem2D type(com_struct), pointer :: com_elem2D_full @@ -17,6 +17,7 @@ integer, dimension(:,:,:), pointer :: s_mpitype_nod3D, r_mpitype_nod3D integer, pointer :: MPIERR + integer, pointer :: MPIERR_IB ! copy for icebergs LA: 2023-05-22 integer, pointer :: npes integer, pointer :: mype integer, pointer :: maxPEnum diff --git a/src/cpl_driver.F90 b/src/cpl_driver.F90 index 91f2225d9..e4e8c9c98 100644 --- a/src/cpl_driver.F90 +++ b/src/cpl_driver.F90 @@ -13,7 +13,7 @@ module cpl_driver ! Modules used ! use mod_oasis ! oasis module - use g_config, only : dt + use g_config, only : dt, use_icebergs, lwiso use o_param, only : rad USE MOD_PARTIT implicit none @@ -22,19 +22,27 @@ module cpl_driver ! Exchange parameters for coupling FESOM with ECHAM6 ! + !---wiso-code + ! define nsend and nrecv as variables instead of fixed parameters + ! (final number of fields depends now on lwiso switch and is set in subroutine cpl_oasis3mct_define_unstr) + #if defined (__oifs) - integer, parameter :: nsend = 7 - integer, parameter :: nrecv = 13 + integer :: nsend = 7 + integer :: nrecv = 13 #else - integer, parameter :: nsend = 4 - integer, parameter :: nrecv = 12 + integer :: nsend = 4 + integer :: nrecv = 12 #endif - integer, dimension(nsend) :: send_id - integer, dimension(nrecv) :: recv_id + ! define send_id and recv_id with variable dimension as nsend and nrecv are now variables) + integer, allocatable, dimension(:) :: send_id + integer, allocatable, dimension(:) :: recv_id + + ! define cpl_send and cpl_recv with variable dimension as nsend and nrecv are now variables) + character(len=32), allocatable, dimension(:) :: cpl_send + character(len=32), allocatable, dimension(:) :: cpl_recv - character(len=32) :: cpl_send(nsend) - character(len=32) :: cpl_recv(nrecv) + !---wiso-code-end character(len=16) :: appl_name ! application name for OASIS use character(len=16) :: comp_name ! name of this component @@ -462,6 +470,14 @@ subroutine cpl_oasis3mct_define_unstr(partit, mesh) ! ... Some initialisation ! ----------------------------------------------------------------- +!---wiso-code + ALLOCATE(cpl_send(nsend)) + ALLOCATE(cpl_recv(nrecv)) + + ALLOCATE(send_id(nsend)) + ALLOCATE(recv_id(nrecv)) +!---wiso-code-end + send_id = 0 recv_id = 0 @@ -637,6 +653,17 @@ subroutine cpl_oasis3mct_define_unstr(partit, mesh) cpl_send( 2)='sit_feom' ! 2. sea ice thickness [m] -> cpl_send( 3)='sie_feom' ! 3. sea ice extent [%-100] -> cpl_send( 4)='snt_feom' ! 4. snow thickness [m] -> +!---wiso-code +! add isotope coupling fields + IF (lwiso) THEN + cpl_send( 5)='o18w_oce' ! -> h2o18 of ocean water + cpl_send( 6)='hdow_oce' ! -> hdo16 of ocean water + cpl_send( 7)='o16w_oce' ! -> h2o16 of ocean water + cpl_send( 8)='o18i_oce' ! -> h2o18 of sea ice + cpl_send( 9)='hdoi_oce' ! -> hdo16 of sea ice + cpl_send(10)='o16i_oce' ! -> h2o16 of sea ice + END IF +!---wiso-code-end #endif @@ -672,6 +699,23 @@ subroutine cpl_oasis3mct_define_unstr(partit, mesh) cpl_recv(10) = 'heat_ico' cpl_recv(11) = 'heat_swo' cpl_recv(12) = 'hydr_oce' +! --- icebergs --- + IF (lwiso) THEN + cpl_recv(13) = 'w1_oce' + cpl_recv(14) = 'w2_oce' + cpl_recv(15) = 'w3_oce' + cpl_recv(16) = 'i1_oce' + cpl_recv(17) = 'i2_oce' + cpl_recv(18) = 'i3_oce' + IF (use_icebergs) THEN + cpl_recv(19) = 'u10w_oce' + cpl_recv(20) = 'v10w_oce' + END IF + ELSE IF (use_icebergs) THEN + cpl_recv(13) = 'u10w_oce' + cpl_recv(14) = 'v10w_oce' + END IF +! --- icebergs --- #endif if (mype .eq. 0) then diff --git a/src/fesom_module.F90 b/src/fesom_module.F90 index fed4f0698..09bb77c5c 100755 --- a/src/fesom_module.F90 +++ b/src/fesom_module.F90 @@ -1,6 +1,7 @@ ! synopsis: save any derived types we initialize ! so they can be reused after fesom_init module fesom_main_storage_module + use iceberg_step USE MOD_MESH USE MOD_ICE USE MOD_TRACER @@ -29,7 +30,20 @@ module fesom_main_storage_module use read_mesh_interface use fesom_version_info_module use command_line_options_module + !---fwf-code, age-code + use g_forcing_param, only: use_landice_water, use_age_tracer + use landice_water_init_interface + use age_tracer_init_interface + !---fwf-code-end, age-code-end + + ! Define icepack module + + ! -------------- + ! LA icebergs: 2023-05-17 + use iceberg_params + use iceberg_step ! Define icepack module + #if defined (__icepack) use icedrv_main, only: set_icepack, init_icepack, alloc_icepack #endif @@ -45,7 +59,7 @@ module fesom_main_storage_module integer :: n, from_nstep, offset, row, i, provided integer :: which_readr ! read which restart files (0=netcdf, 1=core dump,2=dtype) integer :: total_nsteps - integer, pointer :: mype, npes, MPIerr, MPI_COMM_FESOM, MPI_COMM_WORLD + integer, pointer :: mype, npes, MPIerr, MPI_COMM_FESOM, MPI_COMM_WORLD, MPI_COMM_FESOM_IB real(kind=WP) :: t0, t1, t2, t3, t4, t5, t6, t7, t8, t0_ice, t1_ice, t0_frc, t1_frc real(kind=WP) :: rtime_fullice, rtime_write_restart, rtime_write_means, rtime_compute_diag, rtime_read_forcing real(kind=real32) :: rtime_setup_mesh, rtime_setup_ocean, rtime_setup_forcing @@ -128,7 +142,9 @@ subroutine fesom_init(fesom_total_nsteps) f%mype =>f%partit%mype f%MPIerr =>f%partit%MPIerr f%MPI_COMM_FESOM=>f%partit%MPI_COMM_FESOM + f%MPI_COMM_FESOM_IB=>f%partit%MPI_COMM_FESOM_IB f%MPI_COMM_WORLD=>f%partit%MPI_COMM_WORLD + f%npes =>f%partit%npes if(f%mype==0) then write(*,*) @@ -151,12 +167,24 @@ subroutine fesom_init(fesom_total_nsteps) call mesh_setup(f%partit, f%mesh) if (f%mype==0) write(*,*) 'FESOM mesh_setup... complete' - + !===================== ! Allocate field variables ! and additional arrays needed for ! fancy advection etc. !===================== +#if defined (__oasis) + !---wiso-code + IF (lwiso) THEN + nsend = nsend + 6 ! add number of water isotope tracers to coupling parameter nsend, nrecv + nrecv = nrecv + 6 + END IF + !---wiso-code-end + IF (use_icebergs) THEN + nrecv = nrecv + 2 + END IF +#endif + if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call check_mesh_consistency'//achar(27)//'[0m' call check_mesh_consistency(f%partit, f%mesh) if (f%mype==0) f%t2=MPI_Wtime() @@ -197,10 +225,29 @@ subroutine fesom_init(fesom_total_nsteps) if (f%mype==0) f%t5=MPI_Wtime() call compute_diagnostics(0, f%dynamics, f%tracers, f%partit, f%mesh) ! allocate arrays for diagnostic + + !---fwf-code-begin + if(f%mype==0) write(*,*) 'use_landice_water', use_landice_water + if(use_landice_water) call landice_water_init(f%partit, f%mesh) + !---fwf-code-end + + !---age-code-begin + if(f%mype==0) write(*,*) 'use_age_tracer', use_age_tracer + if(use_age_tracer) call age_tracer_init(f%partit, f%mesh) + !---age-code-end + #if defined (__oasis) call cpl_oasis3mct_define_unstr(f%partit, f%mesh) + if(f%mype==0) write(*,*) 'FESOM ----> cpl_oasis3mct_define_unstr nsend, nrecv:',nsend, nrecv #endif + + ! -------------- + ! LA icebergs: 2023-05-17 + if (use_icebergs) then + call allocate_icb(f%partit) + endif + ! -------------- #if defined (__icepack) !===================== @@ -308,6 +355,15 @@ subroutine fesom_runloop(current_nsteps) ! Time stepping !===================== + ! -------------- + ! LA icebergs: 2023-05-17 + f%MPI_COMM_FESOM_IB = f%MPI_COMM_FESOM + if (f%mype==0) then +! write (*,*) 'ib_async_mode, initial omp_num_threads ', ib_async_mode, omp_get_num_threads() + write (*,*) 'current_nsteps, steps_per_ib_step, icb_outfreq :', current_nsteps, steps_per_ib_step, icb_outfreq + end if + ! -------------- + if (f%mype==0) write(*,*) 'FESOM start iteration before the barrier...' call MPI_Barrier(f%MPI_COMM_FESOM, f%MPIERR) @@ -324,10 +380,62 @@ subroutine fesom_runloop(current_nsteps) if (use_global_tides) then call foreph_ini(yearnew, month, f%partit) end if + nstart=f%from_nstep ntotal=f%from_nstep-1+current_nsteps - !do n=f%from_nstep, f%from_nstep-1+current_nsteps do n=nstart, ntotal + if (use_icebergs) then + !n_ib = n + u_wind_ib = u_wind + v_wind_ib = v_wind + f%ice%uice_ib = f%ice%uice + f%ice%vice_ib = f%ice%vice + + ! LA - this causes the blowup ! + ! f%ice%data(size(f%ice%data)) = f%ice%data(2) + ! f%ice%data(size(f%ice%data)-1) = f%ice%data(1) + !!!!!!!!!!!!!!!!!! + + + ! kh 08.03.21 support of different ocean ice and iceberg steps: + ! if steps_per_ib_step is configured greater 1 then UV is modified via call oce_timestep_ale(n) -> call update_vel while + ! the same asynchronous iceberg computation is still active + f%dynamics%uv_ib = f%dynamics%uv + + ! kh 15.03.21 support of different ocean ice and iceberg steps: + ! if steps_per_ib_step is configured greater 1 then tr_arr is modified via call oce_timestep_ale(n) -> call solve_tracers_ale() while + ! the same asynchronous iceberg computation is still active + !tr_arr_ib = tr_arr + Tclim_ib = f%tracers%data(1)%values + Sclim_ib = f%tracers%data(2)%values + + ! kh 15.03.21 support of different ocean ice and iceberg steps: + ! if steps_per_ib_step is configured greater 1 then Tsurf and Ssurf might be changed while + ! the same asynchronous iceberg computation is still active + Tsurf_ib = Tsurf + Ssurf_ib = Ssurf + + ! kh 18.03.21 support of different ocean ice and iceberg steps: + ! if steps_per_ib_step is configured greater 1 then zbar_3d_n and eta_n might be changed while + ! the same asynchronous iceberg computation is still active + !zbar_3d_n_ib = zbar_3d_n + f%mesh%Z_3d_n_ib = f%mesh%Z_3d_n + f%dynamics%eta_n_ib = f%dynamics%eta_n + + ! kh 16.03.21 not modified during overlapping ocean/ice and iceberg computations + ! coriolis_ib = coriolis + ! coriolis_node_ib = coriolis_node + + ! kh 02.02.21 check iceberg computations mode: + ! ib_async_mode == 0: original sequential behavior for both ice sections (for testing purposes, creating reference results etc.) + ! ib_async_mode == 1: OpenMP code active to overlapped computations in first (ocean ice) and second (icebergs) parallel section + ! ib_async_mode == 2: OpenMP code active, but computations still serialized via spinlock (for testing purposes) + + ! ----------------------------------------------------------------------------------- + ! LA asyncronous coupling not included in this FESOM version, yet!! + ! + end if + if (use_global_tides) then call foreph(f%partit, f%mesh) end if @@ -345,7 +453,18 @@ subroutine fesom_runloop(current_nsteps) !___compute horizontal velocity on nodes (originaly on elements)________ if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call compute_vel_nodes'//achar(27)//'[0m' call compute_vel_nodes(f%dynamics, f%partit, f%mesh) - + + + ! -------------- + ! LA icebergs: 2023-05-17 + if (use_icebergs .and. mod(n - 1, steps_per_ib_step)==0) then + if (f%mype==0) write(*,*) '*** step n=',n + !t1_icb = MPI_Wtime() + call iceberg_calculation(f%ice,f%mesh,f%partit,f%dynamics,n) + end if + ! -------------- + + !___model sea-ice step__________________________________________________ f%t1 = MPI_Wtime() if(use_ice) then @@ -368,6 +487,17 @@ subroutine fesom_runloop(current_nsteps) endif if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call ice_timestep(n)'//achar(27)//'[0m' if (f%ice%ice_update) call ice_timestep(n, f%ice, f%partit, f%mesh) + + + ! LA commented for debugging + ! -------------- + ! LA icebergs: 2023-05-17 + if (use_icebergs .and. mod(n, steps_per_ib_step)==0.0) then + call icb2fesom(f%mesh, f%partit, f%ice) + end if + ! -------------- + + !___compute fluxes to the ocean: heat, freshwater, momentum_________ if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call oce_fluxes_mom...'//achar(27)//'[0m' call oce_fluxes_mom(f%ice, f%dynamics, f%partit, f%mesh) ! momentum only @@ -390,6 +520,12 @@ subroutine fesom_runloop(current_nsteps) if (flag_debug .and. f%mype==0) print *, achar(27)//'[34m'//' --> call output (n)'//achar(27)//'[0m' call output (n, f%ice, f%dynamics, f%tracers, f%partit, f%mesh) + ! LA icebergs: 2023-05-17 + if (use_icebergs .and. mod(n, steps_per_ib_step)==0.0) then + call reset_ib_fluxes + end if + !-------------------------- + f%t5 = MPI_Wtime() call restart(n, nstart, f%total_nsteps, .false., f%which_readr, f%ice, f%dynamics, f%tracers, f%partit, f%mesh) f%t6 = MPI_Wtime() @@ -414,6 +550,15 @@ subroutine fesom_finalize() ! EO parameters real(kind=real32) :: mean_rtime(15), max_rtime(15), min_rtime(15) + ! -------------- + ! LA icebergs: 2023-05-17 + if (use_icebergs) then + call iceberg_out(f%partit) + end if + ! -------------- + + + call finalize_output() call finalize_restart() diff --git a/src/gen_forcing_couple.F90 b/src/gen_forcing_couple.F90 index 1701b78a3..ba9247d23 100755 --- a/src/gen_forcing_couple.F90 +++ b/src/gen_forcing_couple.F90 @@ -111,6 +111,10 @@ subroutine update_atm_forcing(istep, ice, tracers, dynamics, partit, mesh) real(kind=WP) :: i_coef, aux real(kind=WP) :: dux, dvy,tx,ty,tvol real(kind=WP) :: t1, t2 + !---wiso-code + integer :: nt1, nt2 + real(kind=WP), parameter :: zwisomin = 1.e-6_WP + !---wiso-code-end #ifdef __oasis real(kind=WP) :: flux_global(2), flux_local(2), eff_vol(2) real(kind=WP), dimension(:), allocatable , save :: exchange @@ -131,13 +135,13 @@ subroutine update_atm_forcing(istep, ice, tracers, dynamics, partit, mesh) ! pointer on necessary derived types real(kind=WP), dimension(:), pointer :: u_ice, v_ice, u_w, v_w real(kind=WP), dimension(:), pointer :: stress_atmice_x, stress_atmice_y + real(kind=WP), dimension(:), pointer :: a_ice, m_ice, m_snow #if defined (__oasis) || defined (__ifsinterface) real(kind=WP), dimension(:), pointer :: oce_heat_flux, ice_heat_flux real(kind=WP), dimension(:), pointer :: tmp_oce_heat_flux, tmp_ice_heat_flux #endif #if defined (__oifs) || defined (__ifsinterface) real(kind=WP), dimension(:), pointer :: ice_temp, ice_alb, enthalpyoffuse - real(kind=WP), dimension(:), pointer :: a_ice, m_ice, m_snow real(kind=WP), pointer :: tmelt real(kind=WP), dimension(:,:,:), pointer :: UVnode #endif @@ -152,10 +156,10 @@ subroutine update_atm_forcing(istep, ice, tracers, dynamics, partit, mesh) v_w => ice%srfoce_v(:) stress_atmice_x => ice%stress_atmice_x(:) stress_atmice_y => ice%stress_atmice_y(:) -#if defined (__oifs) || defined (__ifsinterface) a_ice => ice%data(1)%values(:) m_ice => ice%data(2)%values(:) m_snow => ice%data(3)%values(:) +#if defined (__oifs) || defined (__ifsinterface) ice_temp => ice%data(4)%values(:) ice_alb => ice%atmcoupl%ice_alb(:) enthalpyoffuse => ice%atmcoupl%enthalpyoffuse(:) @@ -218,6 +222,49 @@ subroutine update_atm_forcing(istep, ice, tracers, dynamics, partit, mesh) exchange(:) = a_ice(:) ! ice concentation [%] elseif (i.eq.4) then exchange(:) = m_snow(:) ! snow thickness +!---wiso-code + elseif (i.eq.5) then + exchange(:) = 0.0_WP + if (lwiso) then + nt1 = index_wiso_tracers(1) + nt2 = index_wiso_tracers(3) + where (tracers%data(nt2)%values(1,:) > zwisomin) + exchange(:) = (tracers%data(nt1)%values(1,:)/tracers%data(nt2)%values(1,:)/wiso_smow(1) - 1._WP)*1000._WP ! delta 18O of surface water + end where + end if + + elseif (i.eq.6) then + exchange(:) = 0.0_WP + if (lwiso) then + nt1 = index_wiso_tracers(2) + nt2 = index_wiso_tracers(3) + where (tracers%data(nt2)%values(1,:) > zwisomin) + exchange(:) = (tracers%data(nt1)%values(1,:)/tracers%data(nt2)%values(1,:)/wiso_smow(2) - 1._WP)*1000._WP ! delta D of surface water + end where + end if + + elseif (i.eq.7) then + exchange(:) = 0.0_WP ! delta H216O of surface water is set to zero permill + + elseif (i.eq.8) then + exchange(:) = 0.0_WP + if (lwiso) then + where (tr_arr_ice(:, 3) > zwisomin) + exchange(:) = (tr_arr_ice(:, 1)/tr_arr_ice(:, 3)/wiso_smow(1) - 1._WP)*1000._WP ! delta 18O of sea ice + end where + end if + + elseif (i.eq.9) then + exchange(:) = 0.0_WP + if (lwiso) then + where (tr_arr_ice(:, 3) > zwisomin) + exchange(:) = (tr_arr_ice(:, 2)/tr_arr_ice(:, 3)/wiso_smow(2) - 1._WP)*1000._WP ! delta 18O of sea ice + end where + end if + + elseif (i.eq.10) then + exchange(:) = 0.0_WP ! delta H216O of sea ice is set to zero permill +!---wiso-code-end else print *, 'not installed yet or error in cpl_oasis3mct_send', mype #endif @@ -233,7 +280,7 @@ subroutine update_atm_forcing(istep, ice, tracers, dynamics, partit, mesh) do i=1,nrecv exchange =0.0 call cpl_oasis3mct_recv (i, exchange, action, partit) - !if (.not. action) cycle + !if (.not. action) cycle !Do not apply a correction at first time step! if (i==1 .and. action .and. istep/=1) call net_rec_from_atm(action, partit) if (i.eq.1) then @@ -326,8 +373,98 @@ subroutine update_atm_forcing(istep, ice, tracers, dynamics, partit, mesh) mask=1. call force_flux_consv(enthalpyoffuse, mask, i, 0, action, partit, mesh) end if -#endif +#else + elseif (i.eq.13) then + if (action) then + if (lwiso) then + www3(:) = exchange(:) + else if (use_icebergs) then + u_wind(:) = exchange(:) ! zonal wind + end if + end if + mask=1. + if (lwiso) then + call force_flux_consv(www3, mask, i, 0,action, partit, mesh) + else if (use_icebergs) then + call force_flux_consv(u_wind, mask, i, 0, action, partit, mesh) + end if + elseif (i.eq.14) then + if (action) then + if (lwiso) then + www1(:) = exchange(:) + else if (use_icebergs) then + v_wind(:) = exchange(:) ! meridional wind + end if + end if + mask=1. + if (lwiso) then + call force_flux_consv(www1, mask, i, 0,action, partit, mesh) + else if (use_icebergs) then + call force_flux_consv(v_wind, mask, i, 0, action, partit, mesh) + end if + elseif (i.eq.15) then + if (action) then + ! tot_prec_hdo over water: this variable includes (i) rain over open water and sea ice, (ii) snow and evap over open water, (iii) river runoff + www2(:) = exchange(:) + end if + mask=1. + if (lwiso) then + call force_flux_consv(www2, mask, i, 0,action, partit, mesh) + end if + elseif (i.eq.17) then + if (action) then + ! snowfall_o18 over seaice: this variable includes snow and sublimation over sea ice areas + iii1(:) = exchange(:) + tmp_iii1(:) = exchange(:) ! to reset for flux correction + end if + mask=a_ice + iii1(:) = tmp_iii1(:) + if (lwiso) then + call force_flux_consv(iii1,mask,i,1,action, partit, mesh) ! Northern hemisphere + call force_flux_consv(iii1,mask,i,2,action, partit, mesh) ! Southern Hemisphere + end if + elseif (i.eq.18) then + if (action) then + ! snowfall_hdo over seaice: this variable includes snow and sublimation over sea ice areas + iii2(:) = exchange(:) + tmp_iii2(:) = exchange(:) ! to reset for flux correction + end if + mask=a_ice + iii2(:) = tmp_iii2(:) + if (lwiso) then + call force_flux_consv(iii2,mask,i,1,action, partit, mesh) ! Northern hemisphere + call force_flux_consv(iii2,mask,i,2,action, partit, mesh) ! Southern Hemisphere + end if + elseif (i.eq.16) then + if (action) then + ! snowfall_o16 over seaice: this variable includes snow and sublimation over sea ice areas + iii3(:) = exchange(:) + tmp_iii3(:) = exchange(:) ! to reset for flux correction + end if + mask=a_ice + iii3(:) = tmp_iii3(:) + if (lwiso) then + call force_flux_consv(iii3,mask,i,1,action, partit, mesh) ! Northern hemisphere + call force_flux_consv(iii3,mask,i,2,action, partit, mesh) ! Southern Hemisphere + end if + elseif (i.eq.19) then + if (action) then + u_wind(:) = exchange(:) ! meridional wind + end if + mask=1 + if (use_icebergs.and.lwiso) then + call force_flux_consv(u_wind, mask, i, 0, action, partit, mesh) + end if + elseif (i.eq.20) then + if (action) then + v_wind(:) = exchange(:) ! meridional wind + end if + mask=1 + if (use_icebergs.and.lwiso) then + call force_flux_consv(v_wind, mask, i, 0, action, partit, mesh) + end if end if +# endif #ifdef VERBOSE if (mype==0) then diff --git a/src/gen_forcing_init.F90 b/src/gen_forcing_init.F90 index 7d2df1954..789841eca 100755 --- a/src/gen_forcing_init.F90 +++ b/src/gen_forcing_init.F90 @@ -51,6 +51,10 @@ subroutine forcing_array_setup(partit, mesh) type(t_mesh), intent(in), target :: mesh type(t_partit), intent(inout), target :: partit integer :: n2 + +! kh 19.02.21 + integer :: i + #include "associate_part_def.h" #include "associate_mesh_def.h" #include "associate_part_ass.h" @@ -61,9 +65,32 @@ subroutine forcing_array_setup(partit, mesh) shortwave=0.0_WP longwave=0.0_WP allocate(prec_rain(n2), prec_snow(n2)) + +! kh 19.02.21 + if (ib_async_mode == 0) then + allocate(u_wind(n2), v_wind(n2)) + allocate(u_wind_ib(n2), v_wind_ib(n2)) + else +! kh 19.02.21 support "first touch" idea +!$omp parallel sections num_threads(2) +!$omp section + allocate(u_wind(n2), v_wind(n2)) + do i = 1, n2 + u_wind(i) = 0._WP + v_wind(i) = 0._WP + end do +!$omp section + allocate(u_wind_ib(n2), v_wind_ib(n2)) + do i = 1, n2 + u_wind_ib(i) = 0._WP + v_wind_ib(i) = 0._WP + end do +!$omp end parallel sections + end if + prec_rain=0.0_WP prec_snow=0.0_WP - allocate(u_wind(n2), v_wind(n2)) + !allocate(u_wind(n2), v_wind(n2)) u_wind=0.0_WP v_wind=0.0_WP allocate(Tair(n2), shum(n2)) @@ -95,9 +122,27 @@ subroutine forcing_array_setup(partit, mesh) flux_correction_north=0.0_WP flux_correction_south=0.0_WP flux_correction_total=0.0_WP - +#endif + +#if defined (__oasis) || defined (__ifsinterface) allocate(residualifwflx(n2)) residualifwflx = 0.0_WP + + !---wiso-code + IF (lwiso) THEN + allocate(tmp_iii1(n2), tmp_iii2(n2), tmp_iii3(n2)) + allocate(www1(n2), www2(n2), www3(n2), iii1(n2), iii2(n2), iii3(n2)) + tmp_iii1=0.0_WP + tmp_iii2=0.0_WP + tmp_iii3=0.0_WP + www1=0.0_WP + www2=0.0_WP + www3=0.0_WP + iii1=0.0_WP + iii2=0.0_WP + iii3=0.0_WP + END IF + !---wiso-code-end #endif @@ -137,6 +182,12 @@ subroutine forcing_array_setup(partit, mesh) allocate(runoff_landice(n2)) runoff_landice=0.0_WP end if + !---age-code-begin + if(use_age_tracer) then + allocate(age_tracer_loc_index(n2)) + age_tracer_loc_index=0 + end if + !---age-code-end ! shortwave penetration if(use_sw_pene) then diff --git a/src/gen_model_setup.F90 b/src/gen_model_setup.F90 index c0be423f4..133aad01b 100755 --- a/src/gen_model_setup.F90 +++ b/src/gen_model_setup.F90 @@ -28,6 +28,9 @@ subroutine setup_model(partit) read (fileunit, NML=geometry) read (fileunit, NML=calendar) read (fileunit, NML=run_config) + read (fileunit,NML=icebergs) + +!!$ read (fileunit, NML=machine) close (fileunit) @@ -61,6 +64,7 @@ subroutine setup_model(partit) read (fileunit, NML=forcing_exchange_coeff) read (fileunit, NML=forcing_bulk) read (fileunit, NML=land_ice) + read (fileunit, NML=age_tracer) !---age-code close (fileunit) ! if(use_ice) then diff --git a/src/gen_modules_config.F90 b/src/gen_modules_config.F90 index 9a2838b9d..a23f0c1c5 100755 --- a/src/gen_modules_config.F90 +++ b/src/gen_modules_config.F90 @@ -23,6 +23,7 @@ module g_config !_____________________________________________________________________________ ! *** Paths for all in and out *** +! kh 01.03.21 paths in test environments can easily become longer than 100 characters (the former value) character(MAX_PATH) :: MeshPath='./mesh/' character(MAX_PATH) :: ClimateDataPath='./hydrography/' character(MAX_PATH) :: TideForcingPath='./tide_forcing/' @@ -114,6 +115,27 @@ module g_config ! *** configuration*** logical :: use_sw_pene=.true. logical :: use_ice=.false. + ! to be supplied + ! *** icebergs *** + logical :: use_icebergs=.false. + logical :: turn_off_hf=.false. + logical :: turn_off_fw=.false. + logical :: use_icesheet_coupling=.false. + integer :: ib_num=0 + integer :: steps_per_ib_step=8 + +! kh 02.02.21 +! ib_async_mode == 0: original sequential behavior for both ice sections (for testing purposes, creating reference results etc.) +! ib_async_mode == 1: OpenMP code active to overlapped computations in first (ocean ice) and second (icebergs) parallel section +! ib_async_mode == 2: OpenMP code active but computations still serialized via spinlock (for testing purposes) + integer :: ib_async_mode=0 + integer :: thread_support_level_required=3 ! 2 = MPI_THREAD_SERIALIZED, 3 = MPI_THREAD_MULTIPLE + + namelist /icebergs/ use_icebergs, turn_off_hf, turn_off_fw, use_icesheet_coupling, ib_num, steps_per_ib_step, ib_async_mode, thread_support_level_required + +!wiso-code!!! + logical :: lwiso =.false. ! enable isotope? +!wiso-code!!! logical :: use_floatice = .false. logical :: use_cavity = .false. ! switch on/off cavity usage logical :: use_cavity_partial_cell = .false. ! switch on/off cavity usage @@ -125,7 +147,7 @@ module g_config logical :: flag_warn_cflz=.true. ! switches off cflz warning namelist /run_config/ use_ice,use_floatice, use_sw_pene, use_cavity, & use_cavity_partial_cell, cavity_partial_cell_thresh, & - use_cavity_fw2press, toy_ocean, which_toy, flag_debug, flag_warn_cflz + use_cavity_fw2press, toy_ocean, which_toy, flag_debug, flag_warn_cflz, lwiso !---wiso-code: add lwiso !_____________________________________________________________________________ ! *** others *** @@ -139,4 +161,3 @@ module g_config end module g_config - diff --git a/src/gen_modules_diag.F90 b/src/gen_modules_diag.F90 index acff5c43f..f09417663 100644 --- a/src/gen_modules_diag.F90 +++ b/src/gen_modules_diag.F90 @@ -22,8 +22,8 @@ module diagnostics std_dens_min, std_dens_max, std_dens_N, std_dens, ldiag_trflx, & std_dens_UVDZ, std_dens_DIV, std_dens_DIV_fer, std_dens_Z, std_dens_H, std_dens_dVdT, std_dens_flux, & dens_flux_e, vorticity, zisotherm, tempzavg, saltzavg, compute_diag_dvd_2ndmoment_klingbeil_etal_2014, & - compute_diag_dvd_2ndmoment_burchard_etal_2008, compute_diag_dvd, tuv, suv - + compute_diag_dvd_2ndmoment_burchard_etal_2008, compute_diag_dvd, thetao, tuv, suv + ! Arrays used for diagnostics, some shall be accessible to the I/O ! 1. solver diagnostics: A*x=rhs? ! A=ssh_stiff, x=d_eta, rhs=ssh_rhs; rhs_diag=A*x; @@ -55,6 +55,7 @@ module diagnostics real(kind=WP), save, target :: std_dens_min=1030., std_dens_max=1040. real(kind=WP), save, allocatable, target :: std_dens_UVDZ(:,:,:), std_dens_flux(:,:,:), std_dens_dVdT(:,:), std_dens_DIV(:,:), std_dens_DIV_fer(:,:), std_dens_Z(:,:), std_dens_H(:,:) real(kind=WP), save, allocatable, target :: dens_flux_e(:) + real(kind=WP), save, allocatable, target :: thetao(:) ! sst in K real(kind=WP), save, allocatable, target :: tuv(:,:,:), suv(:,:,:) logical :: ldiag_solver =.false. @@ -886,6 +887,28 @@ subroutine compute_extflds(mode, dynamics, tracers, partit, mesh) end subroutine compute_extflds +! SST in K +subroutine compute_thetao(mode, tracers, partit, mesh) + implicit none + integer, intent(in) :: mode + type(t_tracer), intent(in) , target :: tracers + type(t_mesh) , intent(in) , target :: mesh + type(t_partit), intent(in), target :: partit + logical, save :: firstcall=.true. +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + if (firstcall) then !allocate the stuff at the first call + allocate(thetao(mydim_nod2D)) + firstcall=.false. + if (mode==0) return + end if + + !skipping loop + thetao(:) = tracers%data(1)%values(1,1:myDim_nod2D)+273.15_WP +end subroutine compute_thetao ! ============================================================== subroutine compute_diagnostics(mode, dynamics, tracers, partit, mesh) @@ -923,6 +946,7 @@ subroutine compute_diagnostics(mode, dynamics, tracers, partit, mesh) ! soe exchanged fields requested by IFS/FESOM in NextGEMS. if (ldiag_extflds) call compute_extflds(mode, dynamics, tracers, partit, mesh) + call compute_thetao(mode, tracers, partit, mesh) end subroutine compute_diagnostics ! diff --git a/src/gen_modules_forcing.F90 b/src/gen_modules_forcing.F90 index d3f633ea7..1a5716965 100755 --- a/src/gen_modules_forcing.F90 +++ b/src/gen_modules_forcing.F90 @@ -39,8 +39,20 @@ module g_forcing_param logical :: use_landice_water=.false. integer :: landice_start_mon=1 integer :: landice_end_mon=12 + !---fwf-code-begin + character(MAX_PATH) :: fwf_path='./mesh/' + !---fwf-code-end - namelist /land_ice/ use_landice_water, landice_start_mon, landice_end_mon + namelist /land_ice/ use_landice_water, landice_start_mon, landice_end_mon, fwf_path !---fwf-code, add fwf_path + + !---age-code-begin + logical :: use_age_tracer=.false. + logical :: use_age_mask=.false. + character(MAX_PATH) :: age_tracer_path='./mesh/' + integer :: age_start_year=2000 + + namelist /age_tracer/ use_age_tracer, use_age_mask, age_tracer_path, age_start_year + !---age-code-end end module g_forcing_param ! ==================================================================== @@ -51,6 +63,8 @@ module g_forcing_arrays ! forcing arrays real(kind=WP), allocatable, dimension(:) :: u_wind, v_wind + real(kind=WP), allocatable, dimension(:) :: u_wind_ib, v_wind_ib ! kh 19.02.21 additional arrays for asynchronous iceberg computations + real(kind=WP), allocatable, dimension(:) :: Tair, shum real(kind=WP), allocatable, dimension(:,:) :: u_wind_t, v_wind_t real(kind=WP), allocatable, dimension(:,:) :: Tair_t, shum_t @@ -58,6 +72,13 @@ module g_forcing_arrays real(kind=WP), allocatable, dimension(:) :: prec_rain, prec_snow real(kind=WP), allocatable, dimension(:) :: runoff, evaporation, ice_sublimation real(kind=WP), allocatable, dimension(:) :: cloudiness, press_air + !---wiso-code + real(kind=WP), allocatable, dimension(:) :: www1,www2,www3,iii1,iii2,iii3 + real(kind=WP), allocatable, dimension(:) :: tmp_iii1,tmp_iii2,tmp_iii3 + !---wiso-code-end + !---age-code-begin + integer, allocatable, dimension(:) :: age_tracer_loc_index + !---age-code-end #if defined (__oasis) || defined (__ifsinterface) /* todo: use a single shared definition */ real(kind=WP), target, allocatable, dimension(:) :: sublimation, evap_no_ifrac @@ -68,6 +89,9 @@ module g_forcing_arrays real(kind=WP), allocatable, dimension(:) :: atm_net_fluxes_north, atm_net_fluxes_south real(kind=WP), allocatable, dimension(:) :: oce_net_fluxes_north, oce_net_fluxes_south real(kind=WP), allocatable, dimension(:) :: flux_correction_north, flux_correction_south, flux_correction_total +#endif + +#if defined (__oasis) || defined (__ifsinterface) real(kind=WP), allocatable, dimension(:) :: residualifwflx #endif diff --git a/src/icb_allocate.F90 b/src/icb_allocate.F90 new file mode 100644 index 000000000..169f73126 --- /dev/null +++ b/src/icb_allocate.F90 @@ -0,0 +1,105 @@ +subroutine allocate_icb(partit) + use iceberg_params + use g_config + use MOD_PARTIT + + integer :: n2 +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_part_ass.h" + n2=myDim_nod2D+eDim_nod2D + + allocate(ibhf(n2), ibfwb(n2), ibfwl(n2), ibfwe(n2), ibfwbv(n2)) + ibhf=0 + ibfwb=0 + ibfwl=0 + ibfwe=0 + ibfwbv=0 + + allocate(calving_day(ib_num)) + calving_day = 1 !28.0: September 29 for restart in 1 SEP 97 ! 271.0: September 29 for year 1997 + allocate(height_ib(ib_num)) + height_ib = 1.0 ! 250.0 ! 360.0 + allocate(length_ib(ib_num)) + length_ib = 1.0 + allocate(width_ib(ib_num)) + width_ib = 1.0 + allocate(lon_deg(ib_num)) + lon_deg = 0.0 + allocate(lat_deg(ib_num)) + lat_deg = 0.0 + allocate(ini_u(ib_num)) + ini_u = -0.2 + allocate(ini_v(ib_num)) + ini_v = 0.0 + allocate(Co(ib_num)) + Co = 0.85 + allocate(Ca(ib_num)) + Ca = 0.4 + allocate(Ci(ib_num)) + Ci = 1.0 + allocate(Cdo_skin(ib_num)) + Cdo_skin = 5.0e-3 ! !Cd_oce_ice = 5.0e-3 + allocate(Cda_skin(ib_num)) + Cda_skin = 2.5e-3 ! !similar to Keghouche (2009) + allocate(l_wave(ib_num)) + l_wave = .false. ! (use wave radiation force?) + allocate(conc_sill(ib_num)) + conc_sill =0.90 + allocate(P_sill(ib_num)) + P_sill = 10000.0 + allocate(l_freeze(ib_num)) + l_freeze = .true. ! (use freezing parametrization?) + allocate(draft_scale(ib_num)) + draft_scale = 1.0 ! (account for irregularities of draft + allocate(coriolis_scale(ib_num)) + coriolis_scale = 1.0 ! (scale the body forces, Coriolis and + allocate(surfslop_scale(ib_num)) + surfslop_scale = 1.0 ! surface slope, by those factors: + allocate(rho_icb(ib_num)) + rho_icb = 850.0 !Silva et al., Martin + allocate(rho_h2o(ib_num)) + rho_h2o = 1027.5 + allocate(rho_air(ib_num)) + rho_air = 1.293 + allocate(rho_ice(ib_num)) + rho_ice = 910.0 !910 RT, 945.0 bei Lichey, aus Lemke (1993) + allocate(u_ib(ib_num)) + allocate(v_ib(ib_num)) + allocate(iceberg_elem(ib_num)) + allocate(find_iceberg_elem(ib_num)) + find_iceberg_elem = .true. + allocate(f_u_ib_old(ib_num)) + allocate(f_v_ib_old(ib_num)) + allocate(bvl_mean(ib_num)) + bvl_mean = 0.0 + allocate(lvlv_mean(ib_num)) + lvlv_mean = 0.0 + allocate(lvle_mean(ib_num)) + lvle_mean = 0.0 + allocate(lvlb_mean(ib_num)) + lvlb_mean = 0.0 !averaged volume losses + allocate(fwe_flux_ib(ib_num)) + allocate(fwl_flux_ib(ib_num)) + allocate(fwb_flux_ib(ib_num)) + allocate(fwbv_flux_ib(ib_num)) + allocate(heat_flux_ib(ib_num)) + allocate(lheat_flux_ib(ib_num)) + fwe_flux_ib = 0.0 + fwl_flux_ib = 0.0 + fwb_flux_ib = 0.0 + fwbv_flux_ib = 0.0 + heat_flux_ib = 0.0 + lheat_flux_ib = 0.0 + allocate(arr_block(15*ib_num)) + allocate(elem_block(ib_num)) + allocate(vl_block(4*ib_num)) + allocate(buoy_props(ib_num,13)) + buoy_props = 0.0 + allocate(melted(ib_num)) + melted = .false. + allocate(grounded(ib_num)) + grounded = .false. + allocate(scaling(ib_num)) + scaling = 1 +end subroutine allocate_icb diff --git a/src/icb_coupling.F90 b/src/icb_coupling.F90 new file mode 100644 index 000000000..a715f3925 --- /dev/null +++ b/src/icb_coupling.F90 @@ -0,0 +1,114 @@ +subroutine reset_ib_fluxes() + use o_param + +! kh 18.03.21 not really used here + use g_config + use iceberg_params + + ibfwbv = 0 + ibfwb = 0 + ibfwl = 0 + ibfwe = 0 + ibhf = 0 +end subroutine + + +subroutine prepare_icb2fesom(mesh, partit, ib,i_have_element,localelement,depth_ib) + !transmits the relevant fields from the iceberg to the ocean model + !Lars Ackermann, 17.03.2020 + + use o_param + use MOD_MESH + use g_config + use MOD_PARTIT + use iceberg_params + + logical :: i_have_element + real :: depth_ib + integer :: localelement + integer :: iceberg_node + integer, dimension(3) :: ib_nods_in_ib_elem + integer :: num_ib_nods_in_ib_elem + real :: tot_area_nods_in_ib_elem + integer :: i, ib +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + if(i_have_element) then + num_ib_nods_in_ib_elem=0 + tot_area_nods_in_ib_elem=0 + + do i=1,3 + iceberg_node=elem2d_nodes(i,localelement) + + if (iceberg_node<=mydim_nod2d) then + ib_nods_in_ib_elem(i) = iceberg_node + num_ib_nods_in_ib_elem = num_ib_nods_in_ib_elem + 1 + tot_area_nods_in_ib_elem= tot_area_nods_in_ib_elem + mesh%area(1,iceberg_node) + else + ib_nods_in_ib_elem(i) = 0 + end if + end do + + do i=1, 3 + iceberg_node=ib_nods_in_ib_elem(i) + + if (iceberg_node>0) then + ibfwbv(iceberg_node) = ibfwbv(iceberg_node) - fwbv_flux_ib(ib) / tot_area_nods_in_ib_elem + ibfwb(iceberg_node) = ibfwb(iceberg_node) - fwb_flux_ib(ib) / tot_area_nods_in_ib_elem + ibfwl(iceberg_node) = ibfwl(iceberg_node) - fwl_flux_ib(ib) / tot_area_nods_in_ib_elem + ibfwe(iceberg_node) = ibfwe(iceberg_node) - fwe_flux_ib(ib) / tot_area_nods_in_ib_elem + ibhf(iceberg_node) = ibhf(iceberg_node) - heat_flux_ib(ib) / tot_area_nods_in_ib_elem + end if + end do + end if +end subroutine prepare_icb2fesom + +subroutine icb2fesom(mesh, partit, ice) + !transmits the relevant fields from the iceberg to the ocean model + !Lars Ackermann, 17.03.2020 + + use o_param + +! kh 18.03.21 specification of structure used + use o_arrays, only: water_flux, heat_flux, wiso_flux_oce + use MOD_MESH + use g_config + use MOD_PARTIT + use MOD_ICE + use iceberg_params + integer :: n + real(kind=WP), dimension(:) , pointer :: fresh_wa_flux, net_heat_flux +type(t_ice) , intent(inout), target :: ice +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + fresh_wa_flux => ice%flx_fw(:) + net_heat_flux => ice%flx_h(:) + + do n=1, myDim_nod2d+eDim_nod2D + if (.not.turn_off_hf) then + net_heat_flux(n) = net_heat_flux(n) + ibhf(n) + end if + if (.not.turn_off_fw) then + fresh_wa_flux(n) = fresh_wa_flux(n) + (ibfwb(n)+ibfwl(n)+ibfwe(n)+ibfwbv(n)) + end if + end do +!---wiso-code-begin + if(lwiso) then + do n=1, myDim_nod2D+eDim_nod2D + wiso_flux_oce(n,1)=wiso_flux_oce(n,1)+(ibfwb(n)+ibfwl(n)+ibfwe(n)+ibfwbv(n))*1000.0*wiso_smow(1)*(1-30.0/1000.0) + wiso_flux_oce(n,2)=wiso_flux_oce(n,2)+(ibfwb(n)+ibfwl(n)+ibfwe(n)+ibfwbv(n))*1000.0*wiso_smow(2)*(1-240.0/1000.0) + wiso_flux_oce(n,3)=wiso_flux_oce(n,3)+(ibfwb(n)+ibfwl(n)+ibfwe(n)+ibfwbv(n))*1000.0 + end do + end if +!---wiso-code-end +end subroutine icb2fesom diff --git a/src/icb_dyn.F90 b/src/icb_dyn.F90 new file mode 100644 index 000000000..7a0fb436f --- /dev/null +++ b/src/icb_dyn.F90 @@ -0,0 +1,942 @@ +module iceberg_dynamics + USE MOD_MESH + use MOD_PARTIT + use MOD_ICE + USE MOD_DYN + use iceberg_params + use iceberg_element + !use iceberg_step + +implicit none + + public :: iceberg_dyn + public :: iceberg_frozen + public :: iceberg_acceleration + public :: compute_areas + public :: iceberg_average_andkeel + public :: iceberg_avvelo + + contains + +!============================================================================== +! calculates basically the new iceberg velocity; if melting is enabled, the +! iceberg dimensions are adjusted as well. +! +! Thomas Rackow, 29.06.2010 +!============================================================================== +subroutine iceberg_dyn(mesh, partit, ice, dynamics, ib, new_u_ib, new_v_ib, u_ib, v_ib, lon,lat, depth_ib, & + height_ib, length_ib, width_ib, iceberg_elem, & + mass_ib, Ci, Ca, Co, Cda_skin, Cdo_skin, & + rho_ice, rho_air, rho_h2o, P_sill, conc_sill, frozen_in, & + file1, file2, P_ib, conci_ib, dt_ib, lastsubstep, & + f_u_ib_old, f_v_ib_old, l_semiimplicit, & + semiimplicit_coeff, AB_coeff, file3, rho_icb) + + use g_forcing_arrays !for u_wind, v_wind or u_wind_ib, v_wind_ib respectively + use o_arrays, only: Tsurf_ib, Ssurf_ib + use o_param !for dt + !use iceberg_params,only: l_melt, coriolis_scale !are icebergs allowed to melt? + + integer, intent(IN) :: ib !current iceberg's index + real, intent(OUT) :: new_u_ib, new_v_ib + real, intent(IN) :: u_ib, v_ib + real, intent(IN) :: lon,lat !radiant + real, intent(INOUT) :: depth_ib !inout for case of melting iceberg + real, intent(INOUT) :: height_ib !inout for case of melting iceberg + real, intent(INOUT) :: length_ib !inout for case of melting iceberg + real, intent(INOUT) :: width_ib !inout for case of melting iceberg + integer, intent(IN) :: iceberg_elem !local + real, intent(IN) :: mass_ib + real, intent(IN) :: Ci, Ca, Co, Cda_skin, Cdo_skin + real, intent(IN) :: rho_ice, rho_air, rho_h2o + real, intent(IN) :: P_sill, conc_sill + real, intent(INOUT) :: frozen_in + character, intent(IN) :: file1*80, file2*80 + real, intent(OUT) :: P_ib, conci_ib + real, intent(IN) :: dt_ib + logical, intent(IN) :: lastsubstep + real, intent(INOUT) :: f_u_ib_old, f_v_ib_old + logical, intent(IN) :: l_semiimplicit + real, intent(IN) :: semiimplicit_coeff, AB_coeff + +!LA 2023-03-07 + real, dimension(:), pointer :: hi_ib3, conci_ib3, coriolis + real, dimension(3) :: uo_dz, vo_dz, uo_keel, vo_keel, T_dz,S_dz, T_keel,S_keel !hi_ib3, conci_ib3, + real :: uo_ib, vo_ib, ua_ib, va_ib, ui_ib, vi_ib, hi_ib, uo_skin_ib, vo_skin_ib + real :: Ao, Aa, Ai, Ad, fcoriolis + real :: au_ib, av_ib + real, dimension(2,2) :: SI_matrix + real, dimension(2) :: SI_velo + real :: u_ib_tmp, v_ib_tmp, normold, normnew, abs_omib, abs_omib_skin, ocean_drag + integer :: iter_ib + real :: M_b, M_v, M_e, M_bv, sst_ib, sss_ib ! meltrates (basal, lateral, erosion, lateral 'basal'), temp. & salinity + real :: T_ave_ib, S_ave_ib, T_keel_ib, S_keel_ib + character, intent(IN) :: file3*80 + real, intent(IN) :: rho_icb + +! integer, dimension(3) :: tmp_arr + +type(t_ice) , intent(inout), target :: ice +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +type(t_dyn) , intent(inout), target :: dynamics +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + !OCEAN VELOCITIES: + ! - (uo_ib, vo_ib) : integrated mean velocity at location of iceberg + ! - (uo_skin_ib, vo_skin_ib) : velocity below the draft of the iceberg + ! call iceberg_avvelo_ufkeel(uo_dz,vo_dz, uo_keel,vo_keel, depth_ib,iceberg_elem) + call iceberg_average_andkeel(mesh, partit, dynamics, uo_dz,vo_dz, uo_keel,vo_keel, T_dz,S_dz, T_keel,S_keel, depth_ib,iceberg_elem, ib) + call FEM_3eval(mesh, partit, uo_ib,vo_ib,lon,lat,uo_dz,vo_dz,iceberg_elem) + call FEM_3eval(mesh, partit, uo_skin_ib,vo_skin_ib,lon,lat,uo_keel,vo_keel,iceberg_elem) + + + !TEMPERATURE AND SALINITY: + ! - T_ave_ib, S_ave_ib : Mean T & S (integrated) at location of iceberg + ! - T_keel_ib, S_keel_ib : T & S below the draft of the iceberg (depth_ib) + call FEM_3eval(mesh, partit, T_ave_ib,S_ave_ib,lon,lat,T_dz,S_dz,iceberg_elem) + call FEM_3eval(mesh, partit, T_keel_ib,S_keel_ib,lon,lat,T_keel,S_keel,iceberg_elem) + + + !ATMOSPHERIC VELOCITY ua_ib, va_ib + call FEM_eval(mesh, partit, ua_ib,va_ib,lon,lat,u_wind_ib,v_wind_ib,iceberg_elem) + + !ICE VELOCITY ui_ib, vi_ib + call FEM_eval(mesh, partit, ui_ib,vi_ib,lon,lat,ice%uice_ib,ice%vice_ib,iceberg_elem) + + !ICE THICKNESS (CONCENTRATION) hi_ib, conci_ib + hi_ib3 => ice%data(size(ice%data))%values(:) !ice%m_ice_ib(tmp_arr) + conci_ib3 => ice%data(size(ice%data)-1)%values(:) !ice%a_ice_ib(tmp_arr) + call FEM_3eval(mesh, partit, hi_ib,conci_ib,lon,lat,hi_ib3,conci_ib3,iceberg_elem) + P_ib = 20000. * hi_ib * exp(-20.*(1-conci_ib)) + + call compute_areas(Ao, Aa, Ai, Ad, depth_ib, & + height_ib, length_ib, width_ib, hi_ib) + + coriolis => mesh%coriolis(:) + fcoriolis = coriolis(iceberg_elem) * coriolis_scale(ib) + + call iceberg_acceleration( mesh, partit, dynamics, ib, au_ib, av_ib, Ao, Aa, Ai, Ad, & + uo_ib,vo_ib, uo_skin_ib, vo_skin_ib, & + ua_ib,va_ib, ui_ib,vi_ib, & + u_ib, v_ib, mass_ib, fcoriolis, & + Ci, Ca, Co, Cda_skin, Cdo_skin, & + rho_ice, rho_air, rho_h2o, length_ib, & + iceberg_elem, conci_ib, file1, file2, & + lon, lat, lastsubstep, f_u_ib_old, & + f_v_ib_old, l_semiimplicit, & + semiimplicit_coeff, AB_coeff ) + + + !========================THERMODYNAMICS============================ + if(l_melt) then + + call FEM_eval(mesh, partit, sst_ib,sss_ib,lon,lat,Tsurf_ib,Ssurf_ib,iceberg_elem) + call iceberg_meltrates( M_b, M_v, M_e, M_bv, & + u_ib,v_ib, uo_ib,vo_ib, ua_ib,va_ib, & + sst_ib, length_ib, conci_ib, & + uo_skin_ib, vo_skin_ib, T_keel_ib, S_keel_ib, depth_ib, & + T_ave_ib, S_ave_ib, ib) + + call iceberg_newdimensions(partit, ib, depth_ib,height_ib,length_ib,width_ib,M_b,M_v,M_e,M_bv, & + rho_h2o, rho_icb, file3) + + end if + !====================END OF THERMODYNAMICS========================= + + new_u_ib = u_ib + au_ib * dt_ib + new_v_ib = v_ib + av_ib * dt_ib + + if (l_semiimplicit) then !a matrix multiplication is to be performed + !for semiimpl. coriolis term and implicit + !water drag + + abs_omib = sqrt( (uo_ib - u_ib)**2 + (vo_ib - v_ib)**2 ) + abs_omib_skin = sqrt( (uo_skin_ib - u_ib)**2 + (vo_skin_ib - v_ib)**2 ) + + ocean_drag = (0.5 * Co * rho_h2o * Ao * abs_omib + rho_h2o * Cdo_skin * Ad & + * abs_omib_skin)/mass_ib + + + SI_matrix(1,1) = 1. + dt_ib*ocean_drag + SI_matrix(1,2) = dt_ib*fcoriolis*semiimplicit_coeff + SI_matrix(2,1) =-SI_matrix(1,2) + SI_matrix(2,2) = SI_matrix(1,1) + SI_matrix = (1./( SI_matrix(2,2)**2 + SI_matrix(1,2)**2 )) * SI_matrix + !new velocity + SI_velo = MATMUL(SI_matrix, (/ new_u_ib, new_v_ib /)) + + !for P_sill calculate "effective acceleration" in case of semi-impl. scheme by + !(new velo - old velo)/dt for au_ib (av_ib) isn't the real acceleration + !au_ib = (SI_velo(1) - u_ib)/dt_ib + !av_ib = (SI_velo(2) - v_ib)/dt_ib + + !now the velocity can be updated + new_u_ib = SI_velo(1) + new_v_ib = SI_velo(2) + + else !compute only water drag implicitly, coriolis: AB + + abs_omib = sqrt( (uo_ib - u_ib)**2 + (vo_ib - v_ib)**2 ) + abs_omib_skin = sqrt( (uo_skin_ib - u_ib)**2 + (vo_skin_ib - v_ib)**2 ) + ocean_drag = (0.5 * Co * rho_h2o * Ao * abs_omib + rho_h2o * Cdo_skin * Ad & + * abs_omib_skin)/mass_ib + + SI_matrix(1,1) = 1. + dt_ib*ocean_drag + SI_matrix(1,2) = 0.0 + SI_matrix(2,1) = 0.0 + SI_matrix(2,2) = SI_matrix(1,1) + SI_matrix = (1./(SI_matrix(2,2)**2)) * SI_matrix + !new velocity + SI_velo = MATMUL(SI_matrix, (/ new_u_ib, new_v_ib /)) + + !now the velocity can be updated + new_u_ib = SI_velo(1) + new_v_ib = SI_velo(2) + + end if !matrix-multiplication + + + !icebergs may be frozen in: .true. or .false. + call iceberg_frozen(frozen_in, P_sill, P_ib, conc_sill, conci_ib, ib) + + + new_u_ib = (1-frozen_in) * new_u_ib + frozen_in * ui_ib + new_v_ib = (1-frozen_in) * new_v_ib + frozen_in * vi_ib + +end subroutine iceberg_dyn + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + + +subroutine iceberg_frozen(festgefroren, P_sill, P_ib, conc_sill, conci_ib, ib) + + !use iceberg_params, only : l_freeze !use 'capturing mechanism' of sea ice? + implicit none + + real, intent(OUT) :: festgefroren + real, intent(IN) :: P_sill, P_ib + real, intent(IN) :: conc_sill, conci_ib + integer, intent(IN) :: ib + + festgefroren=0.0 + + if( l_freeze(ib) ) then + festgefroren= factor(P_ib,P_sill,P_sill-3000.) & + * factor(conci_ib,conc_sill,conc_sill-0.04) + end if + + contains + + !================================================================= + ! ... a function for linear transition zone between "frozen in" + ! and "not frozen in", where sill & zone are defined as below + ! + ! sill + ! | + ! /--------- 1 + ! 0 ________/ + ! | + ! zone and value is P_ib or conci_ib. + ! + !================================================================= + real function factor(value, sill,zone) + implicit none + real, intent(IN) :: value + real, intent(IN) :: sill + real, intent(IN) :: zone + + if(value < zone) then + factor=0. + else if(value > sill) then + factor=1. + else + factor=(value-zone)/(sill-zone) + end if + end function factor + +end subroutine iceberg_frozen + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + + +subroutine iceberg_acceleration(mesh, partit, dynamics, ib, au_ib, av_ib, Ao, Aa, Ai, Ad, & + uo_ib,vo_ib, uo_skin_ib, vo_skin_ib, & + ua_ib,va_ib, ui_ib,vi_ib, & + u_ib, v_ib, mass_ib, fcoriolis, & + Ci, Ca, Co, Cda_skin, Cdo_skin, & + rho_ice, rho_air, rho_h2o, length_ib, & + iceberg_elem, conci_ib, file1, file2, & + lon_rad, lat_rad, output, f_u_ib_old, & + f_v_ib_old, l_semiimplicit, & + semiimplicit_coeff, AB_coeff ) + + use o_param !for g + use g_config !for istep + use MOD_PARTIT !for mype + use g_rotate_grid, only: vector_r2g, vector_g2r + !use iceberg_params, only: l_wave, l_tides, l_geo_out, surfslop_scale, ascii_out + use MOD_MESH + use MOD_DYN + + implicit none + + integer, intent(IN) :: ib + real, intent(OUT) :: au_ib, av_ib + real, intent(IN) :: Ao, Aa, Ai, Ad + real, intent(IN) :: uo_ib,vo_ib, uo_skin_ib, vo_skin_ib, ua_ib,va_ib, ui_ib,vi_ib, u_ib,v_ib + real, intent(IN) :: mass_ib, fcoriolis + real, intent(IN) :: Ci, Ca, Co, Cda_skin, Cdo_skin + real, intent(IN) :: rho_ice, rho_air, rho_h2o, length_ib + integer, intent(IN) :: iceberg_elem + real, intent(IN) :: conci_ib + character, intent(IN) :: file1*80, file2*80 + real, intent(IN) :: lon_rad, lat_rad + logical, intent(IN) :: output + real, intent(INOUT):: f_u_ib_old, f_v_ib_old + logical, intent(IN) :: l_semiimplicit + real, intent(IN) :: semiimplicit_coeff, AB_coeff + + real :: vel_atm, wave_amplitude, direction_u, direction_v + real :: abs_omib, abs_amib, abs_imib, abs_omib_skin + real :: ocean_drag_u, ocean_skin_u, air_drag_u, air_skin_u + real :: ice_drag_u, wave_radiation_u, surface_slope_u, slope_tides_u + real :: ocean_drag_v, ocean_skin_v, air_drag_v, air_skin_v + real :: ice_drag_v, wave_radiation_v, surface_slope_v, slope_tides_v + real, dimension(2) :: nablaeta + real, dimension(8) :: accs_u_out, accs_v_out + real, dimension(4) :: vels_u_out, vels_v_out + real :: oneminus_AB !, test1, test2 + integer :: i, istep + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +type(t_dyn) , intent(inout), target :: dynamics +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + !estimate wave height at the icebergs location (Bigg et al., 1997), + !so wave_amplitude = 0.5 * wave_height = 0.5 * const. * abs(atm velo)**2 + vel_atm = sqrt(ua_ib**2 + va_ib**2) + wave_amplitude = 0.5 * 0.02025 * vel_atm**2 + + !assume that waves have same direction as the winds + direction_u = ua_ib / vel_atm + direction_v = va_ib / vel_atm + + !absolute values of relative velocities + abs_omib = sqrt( (uo_ib - u_ib)**2 + (vo_ib - v_ib)**2 ) + abs_amib = sqrt( (ua_ib - u_ib)**2 + (va_ib - v_ib)**2 ) + abs_imib = sqrt( (ui_ib - u_ib)**2 + (vi_ib - v_ib)**2 ) + abs_omib_skin = sqrt( (uo_skin_ib - u_ib)**2 + (vo_skin_ib - v_ib)**2 ) + + ! u-components + ocean_drag_u = (0.5 * Co * rho_h2o * Ao & + * abs_omib * uo_ib)/mass_ib !calculate part of it implicitly + + ocean_skin_u = (rho_h2o * Cdo_skin * Ad & + * abs_omib_skin * uo_skin_ib)/mass_ib !calculate part of it implicitly + + air_drag_u = (0.5 * Ca * rho_air * Aa & + * abs_amib * (ua_ib - u_ib))/mass_ib + air_skin_u = (rho_air * Cda_skin * Ad & + * abs_amib * (ua_ib - u_ib))/mass_ib + + ice_drag_u = (0.5 * Ci * rho_ice * Ai & + * abs_imib * (ui_ib - u_ib))/mass_ib + + if(l_wave(ib)) then + wave_radiation_u = 1./4. * rho_h2o * g * length_ib & + * wave_amplitude**2 * direction_u /mass_ib + else + wave_radiation_u = 0.0 + end if + + !use gradient smoothing for surface slope term + call mean_gradient(mesh, partit, dynamics, iceberg_elem, lon_rad, lat_rad, nablaeta) + + !additional surface slope due to tides + if(l_tides) then + slope_tides_u = 0.0 !-g * sum( opbnd_z_tide(elem2D_nodes(:,iceberg_elem)) * bafux_2D(:,iceberg_elem) ) + else + slope_tides_u = 0.0 + end if + + surface_slope_u = (-g * nablaeta(1) + slope_tides_u) * surfslop_scale(ib) !default scaling is 1.0 + + + ! v-components + ocean_drag_v = (0.5 * Co * rho_h2o * Ao & + * abs_omib * vo_ib)/mass_ib !calculate part of it implicitly + + ocean_skin_v = (rho_h2o * Cdo_skin * Ad & + * abs_omib_skin * vo_skin_ib)/mass_ib !calculate part of it implicitly + + + air_drag_v = (0.5 * Ca * rho_air * Aa & + * abs_amib * (va_ib - v_ib))/mass_ib + air_skin_v = (rho_air * Cda_skin * Ad & + * abs_amib * (va_ib - v_ib))/mass_ib + + ice_drag_v = (0.5 * Ci * rho_ice * Ai & + * abs_imib * (vi_ib - v_ib))/mass_ib + + if(l_wave(ib)) then + wave_radiation_v = 1./4. * rho_h2o * g * length_ib & + * wave_amplitude**2 * direction_v /mass_ib + else + wave_radiation_v = 0.0 + end if + + !additional surface slope due to tides + if(l_tides) then + slope_tides_v = 0.0 !-g * sum( opbnd_z_tide(elem2D_nodes(:,iceberg_elem)) * bafuy_2D(:,iceberg_elem) ) + else + slope_tides_v = 0.0 + end if + + surface_slope_v = (-g * nablaeta(2) + slope_tides_v) * surfslop_scale(ib) !default scaling is 1.0 + + + if (l_semiimplicit) then !USE (SEMI-)IMPLICIT SCHEME for coriolis term + + if (conci_ib .GT. 0.15) then + + au_ib = ocean_drag_u & + + ocean_skin_u & + + air_drag_u & + + air_skin_u & + + ice_drag_u & + + wave_radiation_u & + + surface_slope_u & + + (1.-semiimplicit_coeff)*fcoriolis*v_ib + + av_ib = ocean_drag_v & + + ocean_skin_v & + + air_drag_v & + + air_skin_v & + + ice_drag_v & + + wave_radiation_v & + + surface_slope_v & + - (1.-semiimplicit_coeff)*fcoriolis*u_ib + else + + au_ib = ocean_drag_u & + + ocean_skin_u & + + air_drag_u & + + air_skin_u & + + wave_radiation_u & + + surface_slope_u & + + (1.-semiimplicit_coeff)*fcoriolis*v_ib + + av_ib = ocean_drag_v & + + ocean_skin_v & + + air_drag_v & + + air_skin_v & + + wave_radiation_v & + + surface_slope_v & + - (1.-semiimplicit_coeff)*fcoriolis*u_ib + end if + + else !USE ADAMS-BASHFORTH SCHEME for coriolis + oneminus_AB= 1. - AB_coeff + + if (conci_ib .GT. 0.15) then + + au_ib = ocean_drag_u & + + ocean_skin_u & + + air_drag_u & + + air_skin_u & + + ice_drag_u & + + wave_radiation_u & + + surface_slope_u & + + AB_coeff*fcoriolis*v_ib+oneminus_AB*f_v_ib_old + + + av_ib = ocean_drag_v & + + ocean_skin_v & + + air_drag_v & + + air_skin_v & + + ice_drag_v & + + wave_radiation_v & + + surface_slope_v & + - (AB_coeff*fcoriolis*u_ib) - (oneminus_AB*f_u_ib_old) + else + + au_ib = ocean_drag_u & + + ocean_skin_u & + + air_drag_u & + + air_skin_u & + + wave_radiation_u & + + surface_slope_u & + + AB_coeff*fcoriolis*v_ib+oneminus_AB*f_v_ib_old + + av_ib = ocean_drag_v & + + ocean_skin_v & + + air_drag_v & + + air_skin_v & + + wave_radiation_v & + + surface_slope_v & + - (AB_coeff*fcoriolis*u_ib) - (oneminus_AB*f_u_ib_old) + end if + + !save f*velocity for A.B. scheme before it is updated + f_u_ib_old=fcoriolis*u_ib + f_v_ib_old=fcoriolis*v_ib + + end if !use semiimplicit scheme or AB method? + +! !if(.false.) then +! if(output .AND. ascii_out) then +! +! accs_u_out(1) = ocean_drag_u - (0.5 * Co * rho_h2o * Ao * abs_omib * u_ib)/mass_ib +! accs_u_out(2) = ocean_skin_u - (rho_h2o * Cdo_skin * Ad * abs_omib_skin * u_ib)/mass_ib +! accs_u_out(3) = air_drag_u +! accs_u_out(4) = air_skin_u +! accs_u_out(5) = ice_drag_u +! accs_u_out(6) = wave_radiation_u +! accs_u_out(7) = surface_slope_u +! accs_u_out(8) = fcoriolis*v_ib +! vels_u_out(1) = uo_ib +! vels_u_out(2) = uo_skin_ib +! vels_u_out(3) = ua_ib +! vels_u_out(4) = ui_ib +! +! accs_v_out(1) = ocean_drag_v - (0.5 * Co * rho_h2o * Ao * abs_omib * v_ib)/mass_ib +! accs_v_out(2) = ocean_skin_v - (rho_h2o * Cdo_skin * Ad * abs_omib_skin * v_ib)/mass_ib +! accs_v_out(3) = air_drag_v +! accs_v_out(4) = air_skin_v +! accs_v_out(5) = ice_drag_v +! accs_v_out(6) = wave_radiation_v +! accs_v_out(7) = surface_slope_v +! accs_v_out(8) = -fcoriolis*u_ib +! vels_v_out(1) = vo_ib +! vels_v_out(2) = vo_skin_ib +! vels_v_out(3) = va_ib +! vels_v_out(4) = vi_ib +! +! if(l_geo_out) then +! do i=1,8 +! call vector_r2g(accs_u_out(i), accs_v_out(i), lon_rad, lat_rad, 0) +! end do +! do i=1,4 +! call vector_r2g(vels_u_out(i), vels_v_out(i), lon_rad, lat_rad, 0) +! end do +! end if +! +! !open(unit=icbID,file=file1,position='append') +! !write(icbID,'(2I,12e15.7)') mype, istep, & +! ! accs_u_out(1), accs_u_out(2), & +! ! accs_u_out(3), accs_u_out(4), & +! ! accs_u_out(5), accs_u_out(6), & +! ! accs_u_out(7), accs_u_out(8), & +! ! vels_u_out(1), vels_u_out(2), & +! ! vels_u_out(3), vels_u_out(4) +! ! +! ! +! ! +! !close(icbID) +! +! !open(unit=icbID,file=file2,position='append') +! !write(icbID,'(2I,12e15.7)') mype,istep, & +! ! accs_v_out(1), accs_v_out(2), & +! ! accs_v_out(3), accs_v_out(4), & +! ! accs_v_out(5), accs_v_out(6), & +! ! accs_v_out(7), accs_v_out(8), & +! ! vels_v_out(1), vels_v_out(2), & +! ! vels_v_out(3), vels_v_out(4) +! !close(icbID) +! end if !output + +end subroutine iceberg_acceleration + + +!*************************************************************************************************************************** +!*************************************************************************************************************************** + + +subroutine compute_areas(Ao, Aa, Ai, Ad, depth_ib, & + height_ib, length_ib, width_ib, hi_ib) + implicit none + + real, intent(OUT) :: Ao, Aa, Ai, Ad + real, intent(IN) :: depth_ib, height_ib, length_ib, width_ib, hi_ib + + !area of iceberg exposed to ocean, atm, seaice, horizontal area + Ao = abs(depth_ib) * length_ib + Aa = (height_ib - abs(depth_ib)) * length_ib + Ai = hi_ib * length_ib + Ad = length_ib * width_ib + +end subroutine compute_areas + + +!*************************************************************************************************************************** +!*************************************************************************************************************************** + + +subroutine iceberg_average_andkeel(mesh, partit, dynamics, uo_dz,vo_dz, uo_keel,vo_keel, T_dz,S_dz, T_keel,S_keel, depth_ib,iceberg_elem, ib) + USE MOD_MESH + use o_param + use MOD_PARTIT + use MOD_DYN + + use o_arrays, only: Tclim_ib, Sclim_ib !, UV_ib, Z_3d_n_ib + + use g_clock + use g_forcing_arrays + use g_rotate_grid + + implicit none + + REAL, DIMENSION(3), INTENT(OUT) :: uo_dz + REAL, DIMENSION(3), INTENT(OUT) :: vo_dz + REAL, DIMENSION(3), INTENT(OUT) :: uo_keel + REAL, DIMENSION(3), INTENT(OUT) :: vo_keel + REAL, DIMENSION(3), INTENT(OUT) :: T_dz + REAL, DIMENSION(3), INTENT(OUT) :: S_dz + REAL, DIMENSION(3), INTENT(OUT) :: T_keel + REAL, DIMENSION(3), INTENT(OUT) :: S_keel + REAl, INTENT(IN) :: depth_ib + INTEGER, INTENT(IN) :: iceberg_elem, ib + REAL, dimension(:,:,:), pointer :: UV_ib + + real :: lev_up, lev_low + integer :: m, k, n2, n_up, n_low, cavity_count + ! depth over which is integrated (layer and sum) + real :: dz, ufkeel1, ufkeel2, Temkeel, Salkeel + +type(t_mesh), intent(in) , target :: mesh +type(t_dyn), intent(in) , target :: dynamics +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + UV_IB => dynamics%uv_ib(:,:,:) + cavity_count=0 + + !LOOP: over all nodes of the iceberg element + nodeloop: do m=1, 3 + !for each 2D node of the iceberg element.. + n2=elem2D_nodes(m,iceberg_elem) + + uo_dz(m)=0.0 + vo_dz(m)=0.0 + uo_keel(m)=0.0 + vo_keel(m)=0.0 + T_dz(m)=0.0 + S_dz(m)=0.0 + T_keel(m)=0.0 + S_keel(m)=0.0 + + ! LOOP: consider all neighboring pairs (n_up,n_low) of 3D nodes + ! below n2.. + !innerloop: do k=1, nl+1 + innerloop: do k=1, nlevels_nod2D(n2) + + if( k==1 ) then + lev_up = 0.0 + else + lev_up = mesh%Z_3d_n_ib(k-1, n2) + !lev_up = mesh%Z_3d_n_ib(k-1, n2) + end if + + if( k==nlevels_nod2D(n2) ) then + lev_low = mesh%zbar_n_bot(n2) + else + lev_low = mesh%Z_3d_n_ib(k, n2) + end if + dz = abs( lev_low - lev_up ) + + !if( abs(lev_up)>=abs(depth_ib) ) then + ! ! ...icb bottom above lev_up --> no further integration + !end if + + !if( (abs(coord_nod3D(3, n_low))>abs(depth_ib)) .AND. (abs(coord_nod3D(3, n_up))>abs(depth_ib)) ) then + ! write(*,*) 'INFO, k:',k,'z_up:',coord_nod3D(3, n_up),'z_lo:',coord_nod3D(3, n_low),'depth:',depth_ib,'cavity:',(cavity_flag_nod2d(elem2D_nodes(m,iceberg_elem))==1) + !end if + +#ifdef use_cavity + ! if cavity node .. + if( cavity_flag_nod2d(elem2D_nodes(m,iceberg_elem))==1 .AND. abs(depth_ib)=0.0 for all icebergs + + uo_dz(m)=UV_ib(1,k-1,n2)*abs(depth_ib) + vo_dz(m)=UV_ib(2,k-1,n2)*abs(depth_ib) + uo_keel(m)=UV_ib(1,k-1,n2) + vo_keel(m)=UV_ib(2,k-1,n2) + + T_dz(m)=Tclim_ib(k-1,n2)*abs(depth_ib) + S_dz(m)=Sclim_ib(k-1,n2)*abs(depth_ib) + T_keel(m)=Tclim_ib(k-1,n2) + S_keel(m)=Sclim_ib(k-1,n2) ! check those choices with RT: OK + + exit innerloop + + ! if the lowest z coord is below the iceberg draft, exit + !else if( abs(coord_nod3D(3, n_low))>=abs(depth_ib) .AND. abs(coord_nod3D(3, n_up))<=abs(depth_ib) ) then + + !**************************************************************** + ! LA 23.11.21 case if depth_ib=abs(depth_ib) ) then !.AND. (abs(lev_up)<=abs(depth_ib)) ) then +#else + if( abs(lev_low)>=abs(depth_ib) ) then !.AND. (abs(lev_up)<=abs(depth_ib)) ) then +#endif + if( abs(lev_up)70.) then + write(*,*) 'innerloop, dz:',dz,', depth:',depth_ib,',S_dz(m):',S_dz(m),"m:",m,", k:",k,", Tclim_ib(k-1,n2):",Tclim_ib(k-1,n2),", Tclim_ib(k,n2):", Tclim_ib(k,n2),", Salkeel:",Salkeel,", lev_low:",lev_low,", lev_up:",lev_up + end if + + if(T_dz(m)/abs(depth_ib)>70.) then + write(*,*) 'innerloop, dz:',dz,', depth:',depth_ib,',T_dz(m):',T_dz(m),"m:",m,", k:",k,", Sclim_ib(k-1,n2):",Sclim_ib(k-1,n2),", Sclim_ib(k,n2):", Sclim_ib(k,n2),",Temkeel:",Temkeel,", lev_low:",lev_low,", lev_up:",lev_up + end if + + exit innerloop + + !**************************************************************** + ! LA 23.11.21 case if lev_low==0 + else if(lev_low==lev_up) then + exit innerloop + !**************************************************************** + + else + if( k==1 ) then + cycle + end if + + + if (k.eq.nlevels_nod2D(n2)) then ! LA 2023-08-31 + ! .. and sum up the layer-integrated velocities .. + ! kh 08.03.21 use UV_ib buffered values here + uo_dz(m)=uo_dz(m)+ UV_ib(1,k-1,n2)*dz + vo_dz(m)=vo_dz(m)+ UV_ib(2,k-1,n2)*dz + T_dz(m)=T_dz(m)+ Tclim_ib(k-1,n2)*dz + S_dz(m)=S_dz(m)+ Sclim_ib(k-1,n2)*dz + else + uo_dz(m)=uo_dz(m)+ 0.5*(UV_ib(1,k-1,n2)+UV_ib(1,k,n2))*dz + vo_dz(m)=vo_dz(m)+ 0.5*(UV_ib(2,k-1,n2)+UV_ib(2,k,n2))*dz + T_dz(m)=T_dz(m)+ 0.5*(Tclim_ib(k-1,n2)+ Tclim_ib(k,n2))*dz + S_dz(m)=S_dz(m)+ 0.5*(Sclim_ib(k-1,n2)+ Sclim_ib(k,n2))*dz + end if + + + if(S_dz(m)/abs(depth_ib)>70.) then + write(*,*) 'innerloop, dz:',dz,', depth:',depth_ib,',S_dz(m):',S_dz(m),"m:",m,", k:",k,", Tclim_ib(k-1,n2):",Tclim_ib(k-1,n2),", Tclim_ib(k,n2):", Tclim_ib(k,n2),", lev_low:",lev_low,", lev_up:",lev_up + end if + + if(T_dz(m)/abs(depth_ib)>70.) then + write(*,*) 'innerloop, dz:',dz,', depth:',depth_ib,',T_dz(m):',T_dz(m),"m:",m,", k:",k,", Sclim_ib(k-1,n2):",Sclim_ib(k-1,n2),", Sclim_ib(k,n2):", Sclim_ib(k,n2),", lev_low:",lev_low,", lev_up:",lev_up + end if + + if (k.eq.nlevels_nod2D(n2)) then ! LA 2023-08-31 + uo_keel(m)=UV_ib(1,k-1,n2) + vo_keel(m)=UV_ib(2,k-1,n2) + + T_keel(m)=Tclim_ib(k-1,n2) + S_keel(m)=Sclim_ib(k-1,n2) + else + uo_keel(m)=UV_ib(1,k,n2) + vo_keel(m)=UV_ib(2,k,n2) + + T_keel(m)=Tclim_ib(k,n2) + S_keel(m)=Sclim_ib(k,n2) + end if + end if + + end do innerloop + + ! divide by depth over which was integrated + uo_dz(m)=uo_dz(m)/abs(depth_ib) + vo_dz(m)=vo_dz(m)/abs(depth_ib) + T_dz(m)=T_dz(m)/abs(depth_ib) + S_dz(m)=S_dz(m)/abs(depth_ib) + + end do nodeloop !loop over all nodes of iceberg element + + contains + + real function interpol1D(x0,f0,x1,f1,x) + implicit none + real, intent(IN) :: x0,f0,x1,f1,x + real :: frac + + frac = (f1 - f0)/(x1 - x0) + interpol1D = f0 + frac * (x - x0) + + end function interpol1D +end subroutine iceberg_average_andkeel + + +!*************************************************************************************************************************** +!*************************************************************************************************************************** + +subroutine iceberg_avvelo(mesh, partit, dynamics, uo_dz,vo_dz,depth_ib,iceberg_elem) + USE MOD_MESH + use o_param + use MOD_PARTIT + use MOD_DYN + + use o_arrays, only: Tclim_ib, Sclim_ib !, UV_ib, Z_3d_n_ib + + use g_clock + use g_forcing_arrays + use g_rotate_grid + + implicit none + + REAL, DIMENSION(3), INTENT(OUT) :: uo_dz + REAL, DIMENSION(3), INTENT(OUT) :: vo_dz + REAl, INTENT(IN) :: depth_ib + REAL, dimension(:,:,:), pointer :: UV_ib + INTEGER, INTENT(IN) :: iceberg_elem + + real :: lev_up, lev_low + integer :: m, k, n2, n_up, n_low + ! depth over which is integrated (layer and sum) + real :: dz, ufkeel1, ufkeel2 + ! variables for velocity correction + real :: delta_depth, u_bottom_x, u_bottom_y + +type(t_mesh), intent(in) , target :: mesh +type(t_dyn), intent(in) , target :: dynamics +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + UV_IB => dynamics%uv_ib(:,:,:) + ! loop over all nodes of the iceberg element + do m=1, 3 + !for each 2D node of the iceberg element.. + n2=mesh%elem2D_nodes(m,iceberg_elem) + uo_dz(m)=0.0 + vo_dz(m)=0.0 + + ! ..consider all neighboring pairs (n_up,n_low) of 3D nodes + ! below n2.. + do k=1, nl+1 + +! kh 18.03.21 use zbar_3d_n_ib buffered values here + if( k==1 ) then + lev_up = 0.0 + else + lev_up = mesh%Z_3d_n_ib(k-1, n2) + end if + lev_low = mesh%Z_3d_n_ib(k, n2) + + if (lev_up==lev_low) then + exit + end if + dz = abs( lev_low - lev_up ) + + if(dz < 1) then + !write(*,*) 'z coord of up node', n_up, ':', coord_nod3D(3, n_up), 'z coord of low node', n_low, ':', coord_nod3D(3, n_low) + call par_ex + stop + end if + + ! if the lowest z coord is below the iceberg draft, exit + if ( abs(lev_low)>= abs(depth_ib)) then + + dz = abs( lev_up - depth_ib ) + + if( k==1 ) then + ufkeel1 = UV_ib(1,k,n2) + ufkeel2 = UV_ib(2,k,n2) + uo_dz(m)= ufkeel1*dz + vo_dz(m)= ufkeel2*dz + else + ufkeel1 = interpol1D(abs(lev_up),UV_ib(1,k-1,n2),abs(lev_low),UV_ib(1,k,n2),abs(depth_ib)) + ufkeel2 = interpol1D(abs(lev_up),UV_ib(2,k-1,n2),abs(lev_low),UV_ib(2,k,n2),abs(depth_ib)) + uo_dz(m)=uo_dz(m)+0.5*(UV_ib(1,k-1,n2)+ ufkeel1)*dz + vo_dz(m)=vo_dz(m)+0.5*(UV_ib(2,k-1,n2)+ ufkeel2)*dz + end if + + exit + + else + if( k==1 ) then + cycle + end if + ! .. and sum up the layer-integrated velocities: +! kh 08.03.21 use UV_ib buffered values here + uo_dz(m)=uo_dz(m)+0.5*(UV_ib(1,k-1,n2)+UV_ib(1,k,n2))*dz + vo_dz(m)=vo_dz(m)+0.5*(UV_ib(2,k-1,n2)+UV_ib(2,k,n2))*dz + + end if + end do + + ! divide by depth over which was integrated + uo_dz(m)=uo_dz(m)/abs(depth_ib) + vo_dz(m)=vo_dz(m)/abs(depth_ib) + + end do !loop over all nodes of iceberg element + + contains + + real function interpol1D(x0,f0,x1,f1,x) + implicit none + real, intent(IN) :: x0,f0,x1,f1,x + real :: frac + + frac = (f1 - f0)/(x1 - x0) + interpol1D = f0 + frac * (x - x0) + + end function interpol1D + +end subroutine iceberg_avvelo +end module iceberg_dynamics diff --git a/src/icb_elem.F90 b/src/icb_elem.F90 new file mode 100644 index 000000000..c989f24d3 --- /dev/null +++ b/src/icb_elem.F90 @@ -0,0 +1,879 @@ +module iceberg_element + use MOD_PARTIT + USE MOD_MESH + USE MOD_DYN + use iceberg_params +! use iceberg_dynamics +! use iceberg_step + + implicit none + + public :: mean_gradient + public :: nodal_average + public :: FEM_eval + public :: FEM_3eval + public :: iceberg_elem4all + public :: find_new_iceberg_elem + public :: global2local + public :: com_integer + public :: matrix_inverse_2x2 + + contains + +subroutine mean_gradient(mesh, partit, dynamics, elem, lon_rad, lat_rad, nablaeta) + + integer, intent(IN) :: elem + real, intent(IN) :: lon_rad, lat_rad + real, dimension(2), intent(OUT) :: nablaeta + +!LA 2023-03-07 +real(kind=WP), dimension(:), pointer :: eta_n_ib + integer :: m, node + real, dimension(3) :: gradientx, gradienty + logical :: notmynode + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +type(t_dyn) , intent(inout), target :: dynamics +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + nablaeta = 0. + gradientx= 0. + gradienty= 0. + notmynode= .false. + + do m = 1, 3 + node = elem2D_nodes(m,elem) + call nodal_average(mesh, partit, dynamics, node, gradientx(m), gradienty(m), notmynode) + if (notmynode) exit + end do + + if (notmynode) then !do no smoothing on gradient this time; change this + !so its not dependent on the processor distribution! + + !nablaeta(1) = sum( ssh(elem2D_nodes(:,elem)) * bafux_2D(:,elem) ) + !nablaeta(2) = sum( ssh(elem2D_nodes(:,elem)) * bafuy_2D(:,elem) ) + +!LA 2023-03-07 +eta_n_ib => dynamics%eta_n_ib(:) +! kh 18.03.21 use eta_n_ib buffered values here + nablaeta(1) = sum( eta_n_ib(elem2D_nodes(:,elem)) * gradient_sca(1:3, elem)) + nablaeta(2) = sum( eta_n_ib(elem2D_nodes(:,elem)) * gradient_sca(4:6, elem)) + else + call FEM_3eval(mesh, partit, nablaeta(1),nablaeta(2),lon_rad,lat_rad,gradientx,gradienty,elem) + end if + +end subroutine mean_gradient + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +subroutine nodal_average(mesh, partit, dynamics, local_idx, gradientx, gradienty, notmynode) + use MOD_PARTIT + USE MOD_MESH + USE MOD_DYN + + implicit none + + integer, intent(IN) :: local_idx + real, intent(OUT):: gradientx, gradienty + logical, intent(OUT):: notmynode + + integer :: k, node, idx_elem, elem + real :: area_, patch + +!LA 2023-03-07 +real(kind=WP), dimension(:), pointer :: eta_n_ib + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +type(t_dyn) , intent(inout), target :: dynamics +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + area_ = 0. + patch = 0. + gradientx = 0. + gradienty = 0. + notmynode = .false. + + if(local_idx > myDim_nod2D) then + notmynode = .true. + return !not my node + end if + + do node=1,myDim_nod2D + do k=1, nod_in_elem2D_num(node) + elem = nod_in_elem2D(k,node) + + !do idx_elem = 1, nod_in_elem2D(local_idx)%nmb + !elem = nod_in_elem2D(local_idx)%addresses(idx_elem) + !area_ = voltriangle(elem) + area_ = elem_area(elem) + patch= patch + area_ + + !gradientx = gradientx + area * sum( ssh(elem2D_nodes(:,elem)) * bafux_2D(:,elem) ) + !gradienty = gradienty + area * sum( ssh(elem2D_nodes(:,elem)) * bafuy_2D(:,elem) ) + +!LA 2023-03-07 +eta_n_ib => dynamics%eta_n_ib(:) +! kh 18.03.21 use eta_n_ib buffered values here + gradientx = gradientx + area_ * sum( eta_n_ib(elem2D_nodes(:,elem)) * gradient_sca(1:3, elem)) + gradienty = gradienty + area_ * sum( eta_n_ib(elem2D_nodes(:,elem)) * gradient_sca(4:6, elem)) + end do + end do + + gradientx = gradientx / patch + gradienty = gradienty / patch + +end subroutine nodal_average + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +!================================================================= +! evaluates a given FEM vectorfield at location lon, lat (radiant) +! OUT: u_at_ib, v_at_ib (u and v component at location of iceberg) +! IN : lon, lat (position of iceberg in radiant) +! field_u, field_v (u and v components of vector field) +! elem (the LOCAL element the iceberg lies in) +!================================================================= +subroutine FEM_eval(mesh, partit, u_at_ib,v_at_ib,lon,lat,field_u,field_v,elem) + use MOD_PARTIT !for myDim_nod2D, eDim_nod2D + use o_param !for rad + USE MOD_MESH + + implicit none + real, intent(in) :: lon, lat + integer, intent(in) :: elem + real, intent(out) :: u_at_ib + real, intent(out) :: v_at_ib + real, DIMENSION(3) :: phi, values_u, values_v + real :: lon_deg, lat_deg + real, dimension(2) :: coords_tmp + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit + real, dimension(partit%myDim_nod2D+partit%eDim_nod2D), intent(in) :: field_u + real, dimension(partit%myDim_nod2D+partit%eDim_nod2D), intent(in) :: field_v +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + !convert to deg + lon_deg = lon/rad + lat_deg = lat/rad + coords_tmp = [lon_deg, lat_deg] + + !values of the 3 local basisfunctions at the + !position 'coords' + call locbafu_2D(mesh, partit, phi,elem,coords_tmp) + + values_u = field_u(elem2D_nodes(:,elem)) + values_v = field_v(elem2D_nodes(:,elem)) + + u_at_ib = sum( values_u(:) * phi(:)) + v_at_ib = sum( values_v(:) * phi(:)) + + !correct small errors + if (u_at_ib < minval(values_u, 1)) u_at_ib=minval(values_u, 1) + if (v_at_ib < minval(values_v, 1)) v_at_ib=minval(values_v, 1) + if (u_at_ib > maxval(values_u, 1)) u_at_ib=maxval(values_u, 1) + if (v_at_ib > maxval(values_v, 1)) v_at_ib=maxval(values_v, 1) + + !from E6F: + !interp = sum( values(:) * phi(:)) + !if (interp < minval(values, 1)) interp=minval(values, 1) + !if (interp > maxval(values, 1)) interp=maxval(values, 1) + +end subroutine FEM_eval + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +!================================================================= +! evaluates a given FEM vectorfield at location lon, lat (radiant) +! OUT: u_at_ib, v_at_ib (u and v component at location of iceberg) +! IN : lon, lat (position of iceberg in radiant) +! field_u, field_v (u and v components of vector field) +! elem (the LOCAL element the iceberg lies in) +!================================================================= +subroutine FEM_eval_old(mesh, partit, u_at_ib,v_at_ib,lon,lat,field_u,field_v,elem) + use o_param + use g_clock + use g_forcing_arrays + use g_rotate_grid + + !use iceberg module + !use iceberg_params + + implicit none + real, intent(in) :: lon, lat + integer :: elem + real, intent(out) :: u_at_ib + real, intent(out) :: v_at_ib + + real :: x, y, x1,x2,x3,y1,y2,y3 + real :: T1_u, T1_v, T2_u, T2_v, T3_u, T3_v + real, dimension(2,2) :: inv_matrix + real, dimension(2) :: alphabeta + real :: maxlon, minlon, maxlat, minlat + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit + real, dimension(partit%myDim_nod2D+partit%eDim_nod2D), intent(in) :: field_u + real, dimension(partit%myDim_nod2D+partit%eDim_nod2D), intent(in) :: field_v +!type(t_ice), intent(inout), target :: ice +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + !location of iceberg + x = lon + y = lat + + + !coords of the 3 nodes + x1 = coord_nod2D(1,elem2D_nodes(1,elem)) + y1 = coord_nod2D(2,elem2D_nodes(1,elem)) + x2 = coord_nod2D(1,elem2D_nodes(2,elem)) + y2 = coord_nod2D(2,elem2D_nodes(2,elem)) + x3 = coord_nod2D(1,elem2D_nodes(3,elem)) + y3 = coord_nod2D(2,elem2D_nodes(3,elem)) + + + !check whether iceberg position is in the element + maxlon = maxval( (/ x1, x2, x3 /) ) + minlon = minval( (/ x1, x2, x3 /) ) + maxlat = maxval( (/ y1, y2, y3 /) ) + minlat = minval( (/ y1, y2, y3 /) ) + if( (x > maxlon) .OR. (x < minlon) ) then + write(*,*) 'FEM_eval error: iceberg lon ', x, ' outside element!' + write(*,*) 'maxlon:', maxlon, ' minlon:', minlon + call par_ex + stop + else if( (y > maxlat) .OR. (y < minlat)) then + write(*,*) 'FEM_eval error: iceberg lat', y, ' outside element!' + write(*,*) 'maxlat:', maxlat, ' minlat:', minlat + call par_ex + stop + else + !everything okay + end if + + + !distances wrt node 1 + x2 = x2 - x1 + y2 = y2 - y1 + x3 = x3 - x1 + y3 = y3 - y1 + x = x - x1 + y = y - y1 + + !nodal values Ti_u, Ti_v + T1_u = field_u(elem2D_nodes(1,elem)) + T1_v = field_v(elem2D_nodes(1,elem)) + T2_u = field_u(elem2D_nodes(2,elem)) + T2_v = field_v(elem2D_nodes(2,elem)) + T3_u = field_u(elem2D_nodes(3,elem)) + T3_v = field_v(elem2D_nodes(3,elem)) + + !differences wrt node 1 + T2_u = T2_u - T1_u + T2_v = T2_v - T1_v + T3_u = T3_u - T1_u + T3_v = T3_v - T1_v + + !determine alpha and beta for u velocity + inv_matrix(1,1) = y2 + inv_matrix(1,2) = -y3 + inv_matrix(2,1) = -x2 + inv_matrix(2,2) = x3 + inv_matrix = (1./(x3*y2 - x2*y3)) * inv_matrix + alphabeta = MATMUL(inv_matrix, (/ T3_u, T2_u /)) + + u_at_ib = T1_u + alphabeta(1)*x + alphabeta(2)*y + + !same for v velocity + alphabeta = MATMUL(inv_matrix, (/ T3_v, T2_v /)) + + v_at_ib = T1_v + alphabeta(1)*x + alphabeta(2)*y +end subroutine FEM_eval_old + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +!================================================================= +! interpolates ocean velocity to ib's location (lon, lat) [radiant] +! OUT: u_at_ib, v_at_ib (u and v component at location of iceberg) +! IN : lon, lat (position of iceberg in radiant) +! ocean_u, ocean_v (3 nodal values for u and v component where +! ocean_u(m) is value of +! elem2D_nodes(m,iceberg_elem), m=1,2,3 ) +! elem (the LOCAL element the iceberg lies in) +!================================================================= +subroutine FEM_3eval(mesh, partit, u_at_ib,v_at_ib,lon,lat,ocean_u,ocean_v,elem) + use MOD_PARTIT !for myDim_nod2D, eDim_nod2D + use o_param !for rad + use MOD_MESH + + implicit none + real, intent(in) :: lon, lat + real, dimension(3), intent(in) :: ocean_u + real, dimension(3), intent(in) :: ocean_v + integer, intent(in) :: elem + real, intent(out) :: u_at_ib + real, intent(out) :: v_at_ib + real, DIMENSION(3) :: phi + real :: lon_deg, lat_deg + real, dimension(2) :: coords_tmp + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + !convert to deg + lon_deg = lon/rad + lat_deg = lat/rad + + !values of the 3 local basisfunctions at the + !position 'coords' + coords_tmp = [lon_deg, lat_deg] + call locbafu_2D(mesh, partit, phi,elem, coords_tmp) + + u_at_ib = sum( ocean_u(:) * phi(:)) + v_at_ib = sum( ocean_v(:) * phi(:)) + + !correct small errors + if (u_at_ib < minval(ocean_u, 1)) u_at_ib=minval(ocean_u, 1) + if (v_at_ib < minval(ocean_v, 1)) v_at_ib=minval(ocean_v, 1) + if (u_at_ib > maxval(ocean_u, 1)) u_at_ib=maxval(ocean_u, 1) + if (v_at_ib > maxval(ocean_v, 1)) v_at_ib=maxval(ocean_v, 1) + + !from E6F: + !interp = sum( values(:) * phi(:)) + !if (interp < minval(values, 1)) interp=minval(values, 1) + !if (interp > maxval(values, 1)) interp=maxval(values, 1) +end subroutine FEM_3eval + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +subroutine iceberg_elem4all(mesh, partit, elem, lon_deg, lat_deg) + USE MOD_MESH + use MOD_PARTIT !for myDim_nod2D, myList_elem2D +!#ifdef use_cavity +! use iceberg_params, only: reject_elem +!#endif + + implicit none + + integer, intent(INOUT) :: elem + real, intent(IN) :: lon_deg, lat_deg + logical :: i_have_element + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + call point_in_triangle(mesh, partit, elem, (/lon_deg, lat_deg/)) !all PEs search here + i_have_element= (elem .ne. 0) !up to 3 PEs .true. + + if(i_have_element) then + i_have_element= elem2D_nodes(1,elem) <= myDim_nod2D !1 PE still .true. +#ifdef use_cavity + if( reject_elem(mesh, elem) ) then + elem=0 !reject element + i_have_element=.false. + !write(*,*) 'elem4all: iceberg found in shelf region: elem = 0' + else + elem=myList_elem2D(elem) !global now + end if +#else + elem=myList_elem2D(elem) !global now +#endif + end if + call com_integer(partit, i_have_element,elem) !max 1 PE sends element here; +end subroutine iceberg_elem4all + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +subroutine find_new_iceberg_elem(mesh, partit, old_iceberg_elem, pt, left_mype) + use o_param +!#ifdef use_cavity +! use iceberg_params, only: reject_elem +!#endif + + implicit none + + INTEGER, INTENT(INOUT) :: old_iceberg_elem + REAL, DIMENSION(2), INTENT(IN) :: pt + real, INTENT(OUT) :: left_mype + + INTEGER :: m, n2, idx_elem_containing_n2, elem_containing_n2, ibelem_tmp + REAL, DIMENSION(3) :: werte2D + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + +ibelem_tmp=old_iceberg_elem +left_mype=0.0 + +!for each node of the old iceberg element... +do m=1, 3 + n2=elem2D_nodes(m,old_iceberg_elem) + + if(n2 > myDim_nod2D) cycle !n2 is not my node, so i cannot access all elements around it + + !...and for each element containing this node (so we get all neighbour elements)... + !do idx_elem_containing_n2 = 1, nod_in_elem2D(n2)%nmb + do idx_elem_containing_n2 = 1, nod_in_elem2D_num(n2) + + !elem_containing_n2 = nod_in_elem2D(n2)%addresses(idx_elem_containing_n2) + elem_containing_n2 = nod_in_elem2D(idx_elem_containing_n2,n2) + + call locbafu_2D(mesh, partit, werte2D, elem_containing_n2, pt) + + if (ALL(werte2D <= 1.+ 1.0e-07) .AND. ALL(werte2D >= 0.0- 1.0e-07) ) then + old_iceberg_elem=elem_containing_n2 + +#ifdef use_cavity + if( reject_elem(mesh, old_iceberg_elem) ) then + left_mype=1.0 + !write(*,*) 'iceberg found in shelf region: left_mype = 1' + old_iceberg_elem=ibelem_tmp + end if +#endif + + RETURN + end if + end do +end do + +!no element found (including old element!) +!or the iceberg is way too fast.. +left_mype=1.0 +end subroutine find_new_iceberg_elem + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +SUBROUTINE point_in_triangle(mesh, partit, el2D, pt) + ! returns triangle containing the point pt + ! lon, lat in deg + + USE o_param + !use o_mesh + USE MOD_MESH + USE MOD_PARTIT !for myDim_elem2D + + IMPLICIT NONE + + REAL, DIMENSION(2), INTENT(IN) :: pt + INTEGER, INTENT(OUT) :: el2D + + INTEGER :: i, k, l + REAL, DIMENSION(3) :: werte2D + REAL :: xdiff, ydiff + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + el2D=0 + !DO l=1,elem2D + DO l=1,partit%myDim_elem2D + + call locbafu_2D(mesh, partit, werte2D, l, pt) + + if (ALL(werte2D <= 1.+ 1.0e-07) .AND. ALL(werte2D >= 0.0- 1.0e-07) ) then + el2D=l + !print *,'"point_in_triangle": Das 2D-Element ist ',l, werte2D + EXIT + end if + END DO +END SUBROUTINE point_in_triangle + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +!coords in deg, elem is LOCAL element; +!values of the 3 local basisfunctions at the +!position 'coords' are returned +SUBROUTINE locbafu_2D(mesh, partit, values, elem, coords) + !use o_mesh + USE MOD_MESH + use MOD_PARTIT + USE o_param + + IMPLICIT NONE + + REAL, DIMENSION(3), INTENT(OUT) :: values + INTEGER, INTENT(IN) :: elem + REAL, DIMENSION(2), INTENT(IN) :: coords + + INTEGER :: i,j + INTEGER :: node + INTEGER, DIMENSION(3) :: local_nodes + REAL, DIMENSION(2,3) :: local_coords, local_cart_coords + REAL, DIMENSION(2,2) :: TRANS, TRANS_inv + REAL :: DET + REAL, DIMENSION(2) :: x, x_cart, stdel_coords + REAL, DIMENSION(2) :: vec + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + x(1)=coords(1)*rad + x(2)=coords(2)*rad + do i=1,3 + node=mesh%elem2D_nodes(i,elem) + local_nodes(i)=node + local_coords(:,i)=mesh%coord_nod2D(:,node) + end do + + DO i=1, 2 + if (local_coords(1,i+1)-local_coords(1,1) > 180.*rad) then + local_coords(1,i+1)=local_coords(1,i+1)-360.*rad + end if + if (local_coords(1,i+1)-local_coords(1,1) <-180.*rad) then + local_coords(1,i+1)=local_coords(1,i+1)+360.*rad + end if + END DO + + if (x(1)-local_coords(1,1) > 180.*rad) then + x(1)=x(1)-360.*rad + end if + if (x(1)-local_coords(1,1) <-180.*rad) then + x(1)=x(1)+360.*rad + end if + ! cartesian coordinates + x_cart(1) = r_earth * COS(x(2)) * x(1) + x_cart(2) = r_earth * x(2) + + do i=1,3 + local_cart_coords(1,i) = r_earth * COS(local_coords(2,i)) * local_coords(1,i) + local_cart_coords(2,i) = r_earth * local_coords(2,i) + end do + DO i=1, 2 + TRANS(:,i) = local_cart_coords(:,i+1)-local_cart_coords(:,1) + END DO + call matrix_inverse_2x2(TRANS, TRANS_inv, DET) + + vec=x_cart-local_cart_coords(:,1) + stdel_coords = MATMUL(TRANS_inv, vec) + call stdbafu_2D(values, stdel_coords,1) +END SUBROUTINE locbafu_2D + + + !************************************************************************************************************************** + !*************************************************************************************************************************** + +SUBROUTINE stdbafu_2D(values,x,m) !(stdbafu,x,m) + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: m + REAL, DIMENSION(3,m), INTENT(OUT) :: values + REAL, DIMENSION(2,m), INTENT(IN) :: x + INTEGER :: k + + do k=1,m + values(1,k)=1.-x(1,k)-x(2,k) + values(2,k)= x(1,k) + values(3,k)= x(2,k) + end do +END SUBROUTINE stdbafu_2D + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +subroutine global2local(mesh, partit, aux, tmp) + use MOD_PARTIT !for myDim_elem2D, myList_elem2D + !use o_mesh + USE MOD_MESH + implicit none + + integer, intent(in):: tmp + integer, dimension(tmp), intent(out):: aux + integer:: n + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + aux = 0 + do n = 1, myDim_elem2D + aux(myList_elem2D(n)) = n + end do +end subroutine global2local + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +subroutine com_integer(partit, i_have_element, iceberg_element) + use MOD_PARTIT !for npes + implicit none + + logical, intent(in):: i_have_element + integer, intent(inout):: iceberg_element + + integer:: status(MPI_STATUS_SIZE) + integer:: req + logical:: completed +type(t_partit), intent(inout), target :: partit +!#include "associate_part_def.h" +!#include "associate_part_ass.h" + +! kh 10.02.22 + if(i_have_element) then +!$omp critical + call MPI_IAllreduce(MPI_IN_PLACE, iceberg_element, 1, MPI_INTEGER, MPI_SUM, partit%MPI_COMM_FESOM_IB, req, partit%MPIERR_IB) +!$omp end critical + else +!$omp critical + call MPI_IAllreduce(0, iceberg_element, 1, MPI_INTEGER, MPI_SUM, partit%MPI_COMM_FESOM_IB, req, partit%MPIERR_IB) +!$omp end critical + end if + + completed = .false. + do while (.not. completed) +!$omp critical + CALL MPI_TEST(req, completed, status, partit%MPIERR_IB) +!$omp end critical + end do + + end subroutine com_integer + + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +! ! kh 10.02.21 +! subroutine com_values_old_dont_use(partit, i_have_element, arr, iceberg_element) +! use MOD_PARTIT !for npes +! implicit none +! +! logical, intent(in) :: i_have_element +! real, intent(inout) :: arr(15) +! integer, intent(inout) :: iceberg_element +! +! logical:: he_has_element +! real :: arr_r(15) +! integer:: i, sender, status(MPI_STATUS_SIZE) +!!type(t_partit), intent(inout), target :: partit +!!#include "associate_part_def.h" +!!#include "associate_part_ass.h" +! +! if (mype==0) then +! do i=1, npes-1 +! CALL MPI_RECV(he_has_element, 1, MPI_LOGICAL, MPI_ANY_SOURCE, 0, MPI_COMM_FESOM, status, MPIerr ) +! sender = status(MPI_SOURCE) +! if (he_has_element) then +! CALL MPI_RECV(arr_r, 15, MPI_DOUBLE_PRECISION, sender, 1, MPI_COMM_FESOM, status, MPIerr ) +! CALL MPI_RECV(iceberg_element, 1, MPI_DOUBLE_PRECISION, sender, 2, MPI_COMM_FESOM, status, MPIerr ) +! arr=arr_r +! end if +! end do +! else +! CALL MPI_SEND(i_have_element, 1, MPI_LOGICAL, 0, 0, MPI_COMM_FESOM, MPIerr ) +! if (i_have_element) then +! CALL MPI_SEND(arr, 15, MPI_DOUBLE_PRECISION,0, 1, MPI_COMM_FESOM, MPIerr ) +! CALL MPI_SEND(iceberg_element, 1, MPI_INTEGER,0, 2, MPI_COMM_FESOM, MPIerr ) +! end if +! end if +! +!! if (mype==0) then +!! do i=1, npes-1 +!! CALL MPI_RECV(he_has_element, 1, MPI_LOGICAL, MPI_ANY_SOURCE, 0, MPI_COMM_WORLD, status, MPIerr ) +!! sender = status(MPI_SOURCE) +!! if (he_has_element) then +!! CALL MPI_RECV(arr_r, 15, MPI_DOUBLE_PRECISION, sender, 1, MPI_COMM_WORLD, status, MPIerr ) +!! CALL MPI_RECV(iceberg_element, 1, MPI_DOUBLE_PRECISION, sender, 2, MPI_COMM_WORLD, status, MPIerr ) +!! arr=arr_r +!! end if +!! end do +!! else +!! CALL MPI_SEND(i_have_element, 1, MPI_LOGICAL, 0, 0, MPI_COMM_WORLD, MPIerr ) +!! if (i_have_element) then +!! CALL MPI_SEND(arr, 15, MPI_DOUBLE_PRECISION,0, 1, MPI_COMM_WORLD, MPIerr ) +!! CALL MPI_SEND(iceberg_element, 1, MPI_INTEGER,0, 2, MPI_COMM_WORLD, MPIerr ) +!! end if +!! end if +! +! ! *** PROC 0 SENDS ICEBERG ELEMENT TO ALL OTHERS *** +! ! +! !1. buffer - Startadresse des Datenpuffers +! !2. count - Anzahl der Elemente im Puffer (integer) +! !3. datatype - Datentyp der Pufferelemente (handle) +! !4. root - Wurzelproze�; der, welcher sendet (integer) +! !5. comm - Kommunikator (handle) +! CALL MPI_BCAST(arr, 15, MPI_DOUBLE_PRECISION, 0, MPI_COMM_FESOM, MPIerr) +! CALL MPI_BCAST(iceberg_element, 1, MPI_INTEGER, 0, MPI_COMM_FESOM, MPIerr) +! !CALL MPI_BCAST(arr, 15, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, MPIerr) +! !CALL MPI_BCAST(iceberg_element, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, MPIerr) +! +! ! kh 10.02.21 +! end subroutine com_values_old_dont_use + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +! !============================================================================== +!! routine for visualizing the distribution of the processors involved +!! +!! Thomas Rackow, 30.07.2010 +!!============================================================================== +!SUBROUTINE processor_distr(mesh, partit) +! !use o_mesh +! USE MOD_MESH +! use o_param +!! use i_therm_param +!! use i_param +!! use i_arrays +! use MOD_PARTIT +! +!! kh 18.03.21 not really used here +!! use o_arrays +! +! use g_clock +! use g_forcing_arrays +! use g_rotate_grid +! +! IMPLICIT NONE +! +! character :: mype_char*3 +! INTEGER :: m, row +! +!type(t_mesh), intent(in) , target :: mesh +!type(t_partit), intent(inout), target :: partit +!#include "associate_part_def.h" +!#include "associate_mesh_def.h" +!#include "associate_part_ass.h" +!#include "associate_mesh_ass.h" +! +! write(mype_char,*) mype +! !left-adjust the string.. +! mype_char = adjustl(mype_char) +! +! DO m=1, myDim_nod2d +! row=myList_nod2d(m) +! open(unit=mype+66, file='/work/ab0046/a270046/results/ICB02processor' // trim(mype_char) // '.dat', position='append') +! ! global local lon lat PE +! write(mype+66,*) row, m, coord_nod2D(1,m), coord_nod2D(2,m), mype +! close(mype+66) +! END DO +!END SUBROUTINE processor_distr + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +!!============================================================================== +!! routine for visualizing the amplitude of the main 4 tidal constituents +!! +!! Thomas Rackow, 18.12.2010 +!!============================================================================== +!SUBROUTINE eides_distr(partit) +!! use o_mesh +! use o_param +! ! use i_therm_param +! ! use i_param +! ! use i_arrays +! use MOD_PARTIT +!! kh 18.03.21 not really used here +!! use o_arrays +! +! use g_clock +! use g_forcing_arrays +! use g_rotate_grid +! +! IMPLICIT NONE +! +! character :: mype_char*3 +! INTEGER :: m, row +!type(t_partit), intent(inout), target :: partit +!#include "associate_part_def.h" +!#include "associate_part_ass.h" +! +! write(mype_char,*) mype +! !left-adjust the string.. +! mype_char = adjustl(mype_char) +! +! !DO m=1, myDim_nod2d +! !row=myList_nod2d(m) +! !open(unit=mype+66, file='/work/ab0046/a270046/results/TIDESprocessor' // trim(mype_char) // '.dat', position='append') +! !! global local M2 S2 K1 O1 +! !write(mype+66,*) row, m, tide_z_amp(m,1), tide_z_amp(m,2), tide_z_amp(m,3), tide_z_amp(m,4) +! !close(mype+66) +! !END DO +!END SUBROUTINE tides_distr + +!LA from oce_mesh_setup ofr iceberg coupling +subroutine matrix_inverse_2x2 (A, AINV, DET) + ! + ! Coded by Sergey Danilov + ! Reviewed by Qiang Wang + !------------------------------------------------------------- + + implicit none + + real(kind=8), dimension(2,2), intent(IN) :: A + real(kind=8), dimension(2,2), intent(OUT) :: AINV + real(kind=8), intent(OUT) :: DET + integer :: i,j + + DET = A(1,1)*A(2,2) - A(1,2)*A(2,1) + if ( DET .eq. 0.0 ) then + do j=1,2 + write(*,*) (A(i,j),i=1,2) + end do + stop 'SINGULAR 2X2 MATRIX' + else + AINV(1,1) = A(2,2)/DET + AINV(1,2) = -A(1,2)/DET + AINV(2,1) = -A(2,1)/DET + AINV(2,2) = A(1,1)/DET + endif +end subroutine matrix_inverse_2x2 +end module iceberg_element diff --git a/src/icb_modules.F90 b/src/icb_modules.F90 new file mode 100644 index 000000000..cda937e6c --- /dev/null +++ b/src/icb_modules.F90 @@ -0,0 +1,145 @@ +module iceberg_params +implicit none +save + !integer,parameter :: ib_num ! realistic dataset comprising 6912 icebergs + real,dimension(:), allocatable:: calving_day !271.0 !28.0: September 29 for restart in 1 SEP 97 ! 271.0: September 29 for year 1997 + + !days since beginning of year (since FESOM first started); + !2.5 starts an iceberg at 3rd day, 12.00, with respect to model start; + !For restarts, calving_day is subtracted by the number of modelled days (see iceberg_out subroutine) + + ! ============= REALISTIC INITIAL ICEBERG DISTRIBUTION (SEP/OCT 1997 SNAPSHOT) IN NEAR-COASTAL STRIP AROUND ANTARCTICA =================== ! + ! + ! from the article 'Near-coastal circum-Antarctic iceberg size distributions determined from Synthetic Aperture Radar images' + ! by Wesche and Dierking (2014). + real,dimension(:), allocatable:: height_ib + + !read from file in init_icebergs + real,dimension(:), allocatable:: length_ib + real,dimension(:), allocatable:: width_ib + real,dimension(:), allocatable:: lon_deg + real,dimension(:), allocatable:: lat_deg + !in case (l_initial .AND. l_iniuser) = .true. ; + !initial zonal velocity (positive is to the east): + real,dimension(:), allocatable:: ini_u + + !initial meridional velocity (positive is to the north): + real,dimension(:), allocatable:: ini_v + + ! ================================================================================================================= ! + ! ========= Lichey & Hellmer values ========= ! + real,dimension(:), allocatable:: Co + real,dimension(:), allocatable:: Ca + real,dimension(:), allocatable:: Ci + real,dimension(:), allocatable:: Cdo_skin ! !Cd_oce_ice = 5.0e-3 + real,dimension(:), allocatable:: Cda_skin ! !similar to Keghouche (2009) + ! =========================================== ! + logical,dimension(:), allocatable:: l_wave ! (use wave radiation force?) + ! =========================================== ! + real,dimension(:), allocatable:: conc_sill + real,dimension(:), allocatable:: P_sill + logical,dimension(:), allocatable:: l_freeze ! (use freezing parametrization?) + ! =========================================== ! + logical :: l_melt = .true. ! (use melting parametrization?) + logical :: l_weeksmellor = .true. ! (use weeks & mellor stability criterion?) + logical :: l_allowgrounding = .true. ! (are icebergs allowed to ground?) + real,dimension(:), allocatable:: draft_scale ! (account for irregularities of draft + ! =========================================== ! + logical :: l_tides = .false. ! (simulate sensitivity to tides? !!check for HLRN-III!!) + ! =========================================== ! + logical :: l_initial = .true. ! (use initial iceberg velocities?) + logical :: l_iniuser = .false. ! (prescribe init. velo or let model decide?) + ! =========================================== ! + real :: smallestvol_icb = 10.0 ! (smallest iceberg volume in m^3?) + real :: maxspeed_icb = 3.0 ! (cap iceberg speed at ?? m/s?) !security value !not used + ! ========= For sensitivity studies ========= ! + real,dimension(:), allocatable:: coriolis_scale ! (scale the body forces, Coriolis and + real,dimension(:), allocatable:: surfslop_scale ! surface slope, by those factors: + ! =========================================== ! + real,dimension(:), allocatable:: rho_icb !Silva et al., Martin + real,dimension(:), allocatable:: rho_h2o + real,dimension(:), allocatable:: rho_air + real,dimension(:), allocatable:: rho_ice !910 RT, 945.0 bei Lichey, aus Lemke (1993) + + !python version + character(100):: IcebergRestartPath='iceberg.restart' + character(100):: IcebergRestartPath_ISM='iceberg.restart.ISM' + character(100):: num_non_melted_icb_file='num_non_melted_icb_file' + character(100):: file_icb_netcdf='buoys_track.nc' !output file of buoys/icebergs + character(100):: buoys_xlon_file='icb_longitude.dat' !buoy position in deg + character(100):: buoys_ylat_file='icb_latitude.dat' !buoy position in deg + character(100):: length_icb_file='icb_length.dat' !iceberg length [m] + character(100):: width_icb_file='icb_length.dat' !iceberg width [m] + character(100):: height_icb_file='icb_height.dat' !iceberg height [m] + character(100):: scaling_file='icb_scaling.dat' !scaling factor + + !===== OUTPUT RELATED SETTINGS ===== + integer :: icb_outfreq = 180 ! 180; for FESOM_dt=2min this is 6 hourly output !120; for FESOM_dt=3min this is 6 hourly output + logical :: l_geo_out = .true. ! output in unrotated (.true.) or rotated coordinates + logical :: ascii_out = .false. ! old ascii output (slow, more detailed); false: faster nc output + !===== NUMERICS (DONT HAVE TO BE CHANGED) ===== + logical :: l_semiimplicit = .true. !false: adams-bashforth for coriolis + real :: semiimplicit_coeff = 1.0 !1. fully implicit, 0.5 no damping + real :: AB_coeff = 1.53 !1.5 original AB (amplifying), 1.6 stabilized + !===== NOTHING MUST BE CHANGED BELOW THIS LINE ===== + real,dimension(:), allocatable:: u_ib, v_ib + integer,dimension(:), allocatable:: iceberg_elem + logical,dimension(:), allocatable:: find_iceberg_elem + real,dimension(:), allocatable:: f_u_ib_old, f_v_ib_old + real,dimension(:), allocatable:: bvl_mean, lvlv_mean, lvle_mean, lvlb_mean !averaged volume losses + !real,dimension(:), allocatable:: fw_flux_ib, heat_flux_ib + real,dimension(:), allocatable:: fwe_flux_ib, fwl_flux_ib, fwb_flux_ib, fwbv_flux_ib, heat_flux_ib, lheat_flux_ib + + !===== FRESHWATER AND HEAT ARRAYS ON FESOM GRID ===== + real,dimension(:), allocatable:: ibhf !icb heat flux into ocean + real,dimension(:), allocatable:: ibfwb !freshwater flux into ocean from basal melting + real,dimension(:), allocatable:: ibfwbv !freshwater flux into ocean from basal melting + real,dimension(:), allocatable:: ibfwl !freshwater flux into ocean from lateral melting + real,dimension(:), allocatable:: ibfwe !freshwater flux into ocean from erosion + integer,dimension(:), allocatable:: scaling !scaling factor + + logical,dimension(:), allocatable:: melted !1 if iceberg melted, 0 otherwise + logical,dimension(:), allocatable:: grounded !1 if iceberg grounded, 0 otherwise + integer :: num_non_melted_icb = 0 !1 if iceberg melted, 0 otherwise + !for communication + real,dimension(:), allocatable:: arr_block + integer,dimension(:), allocatable:: elem_block + real,dimension(:), allocatable:: vl_block + + !array for output in netcdf + real,dimension(:,:), allocatable:: buoy_props + integer:: save_count_buoys + real:: prev_sec_in_year +!**************************************************************************************************************************** +!**************************************************************************************************************************** +#ifdef use_cavity + contains + ! true if all nodes of the element are either "real" model boundary nodes or shelf nodes + logical function reject_elem(mesh, elem) + USE MOD_MESH + implicit none + integer, intent(in) :: elem +type(t_mesh), intent(in) , target :: mesh +#include "associate_mesh_def.h" +#include "associate_mesh_ass.h" + +! kh 09.08.21 change index_nod2d -> bc_index_nod2d? + reject_elem = all( (cavity_flag_nod2d(elem2D_nodes(:,elem))==1) .OR. (index_nod2d(elem2D_nodes(:,elem))==1) ) + end function reject_elem + + ! gives number of "coastal" nodes in cavity setup, i.e. number of nodes that are + ! either "real" model boundary nodes or shelf nodes + integer function coastal_nodes(mesh, elem) + USE MOD_MESH + implicit none + integer, intent(in) :: elem +type(t_mesh), intent(in) , target :: mesh +#include "associate_part_def.h" +#include "associate_part_ass.h" + +! kh 09.08.21 change index_nod2d -> bc_index_nod2d? + coastal_nodes = count( (cavity_flag_nod2d(elem2D_nodes(:,elem))==1) .OR. (index_nod2d(elem2D_nodes(:,elem))==1) ) + end function coastal_nodes +#endif + +end module iceberg_params diff --git a/src/icb_step.F90 b/src/icb_step.F90 new file mode 100644 index 000000000..03457192e --- /dev/null +++ b/src/icb_step.F90 @@ -0,0 +1,2068 @@ +module iceberg_step + USE MOD_MESH + use MOD_PARTIT + use MOD_ICE + USE MOD_DYN + use iceberg_params + use iceberg_dynamics + use iceberg_element + +implicit none + + public :: iceberg_calculation + public :: iceberg_step1 + public :: get_total_iceberg_area + public :: iceberg_step2 + public :: initialize_velo + public :: trajectory + public :: depth_bathy + public :: parallel2coast + public :: projection + public :: iceberg_restart + public :: iceberg_restart_with_icesheet + public :: iceberg_out + public :: init_buoys + public :: init_icebergs + public :: init_icebergs_with_icesheet + public :: determine_save_count + public :: init_buoy_output + public :: write_buoy_props_netcdf + +contains + +subroutine iceberg_calculation(ice, mesh, partit, dynamics, istep) + !======================================================================! + ! ! + ! ICEBERG MODULE FOR FESOM ! + ! ! + !======================================================================! + ! last update: 07.10.2015, T. Rackow (AWI) + !======================================================================! + + !==================== MODULES & DECLARATIONS ==========================!= + != + use o_param !for ? != + use g_config !for istep, step_per_day, logfile_outfreq != +!= + implicit none != + != + integer :: ib, times, istep + integer :: istep_end_synced + integer:: req, status(MPI_STATUS_SIZE) + logical:: completed + real(kind=8) :: t0, t1, t2, t3, t4, t0_restart, t1_restart != + logical :: firstcall=.true. != + logical :: lastsubstep != + != + real :: arr_from_block(15) != + integer :: elem_from_block != + real :: vl_from_block(4) != + real,dimension(15*ib_num):: arr_block_red != + integer,dimension(ib_num):: elem_block_red != + real, dimension(4*ib_num):: vl_block_red != + +type(t_ice), intent(inout), target :: ice +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +type(t_dyn) , intent(inout), target :: dynamics +!==================== MODULES & DECLARATIONS ==========================!= +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + +! kh 16.03.21 (asynchronous) iceberg computation starts with the content in common arrays at istep and will merge its results at istep_end_synced + istep_end_synced = istep + steps_per_ib_step - 1 + + if(firstcall) then + !overwrite icb_modules if restart, initialize netcdf output if no restart: + + t0_restart=MPI_Wtime() + if (use_icesheet_coupling) then + call iceberg_restart_with_icesheet(partit) + else + call iceberg_restart(partit) + end if + t1_restart=MPI_Wtime() + firstcall = .false. + !call init_global_tides + !call tides_distr + end if + + t0=MPI_Wtime() + + !call update_global_tides !for each timestep istep once + + !write ib values in 2 larger arrays for + !faster communication via ALLREDUCE + arr_block = 0.0 + elem_block = 0 + !for communication of averaged volume losses + vl_block = 0.0 + + !the original routine iceberg_step has been splitted + !in the part before (step1) and after (step2) communication + ! + !this results in two do-loops BUT the expensive routine + !com_values can be replaced by MPI_ALLREDUCE + + + !============================= STEP 1 =================================! + + + do ib=1, ib_num + lastsubstep = .false. + if( real(istep) > real(step_per_day)*calving_day(ib) ) then !iceberg calved + + lastsubstep = .true. !do output every timestep + + if( .not.melted(ib) ) then + call iceberg_step1(ice, mesh, partit, dynamics, ib, height_ib(ib),length_ib(ib),width_ib(ib), lon_deg(ib),lat_deg(ib),& + Co(ib),Ca(ib),Ci(ib), Cdo_skin(ib),Cda_skin(ib), rho_icb(ib), & + conc_sill(ib),P_sill(ib), rho_h2o(ib),rho_air(ib),rho_ice(ib), & + u_ib(ib),v_ib(ib), iceberg_elem(ib), find_iceberg_elem(ib), lastsubstep,& + f_u_ib_old(ib), f_v_ib_old(ib), l_semiimplicit, & + semiimplicit_coeff, AB_coeff, istep) + end if + end if + end do + + t1=MPI_Wtime() + + + !========================== COMMUNICATION =============================! + + !all PEs need the array arr(15) and the iceberg element + !in step2 + !ALLREDUCE: arr_block, elem_block + + arr_block_red = 0.0 + elem_block_red= 0 + vl_block_red = 0.0 + +!$omp critical + call MPI_IAllREDUCE(arr_block, arr_block_red, 15*ib_num, MPI_DOUBLE_PRECISION, MPI_SUM, partit%MPI_COMM_FESOM_IB, req, partit%MPIERR_IB) +!$omp end critical + + completed = .false. + do while (.not. completed) +!$omp critical +CALL MPI_TEST(req, completed, status, partit%MPIERR_IB) +!$omp end critical + end do + +!$omp critical + call MPI_IAllREDUCE(elem_block, elem_block_red, ib_num, MPI_INTEGER, MPI_SUM, partit%MPI_COMM_FESOM_IB, req, partit%MPIERR_IB) +!$omp end critical + +completed = .false. + do while (.not. completed) +!$omp critical + CALL MPI_TEST(req, completed, status, partit%MPIERR_IB) +!$omp end critical + end do + +!$omp critical + call MPI_IAllREDUCE(vl_block, vl_block_red, 4*ib_num, MPI_DOUBLE_PRECISION, MPI_SUM, partit%MPI_COMM_FESOM_IB, req, partit%MPIERR_IB) +!$omp end critical + + completed = .false. + do while (.not. completed) +!$omp critical + CALL MPI_TEST(req, completed, status, partit%MPIERR_IB) +!$omp end critical + end do + + buoy_props=0. + + t2=MPI_Wtime() + + + !============================= STEP 2 =================================! + + do ib=1, ib_num + + !get the smaller array arr(15) and + !the iceberg element for iceberg ib + !as before + arr_from_block = arr_block_red( (ib-1)*15+1 : ib*15) + elem_from_block= elem_block_red(ib) + !averaged volume losses + vl_from_block = vl_block_red( (ib-1)*4+1 : ib*4) + bvl_mean(ib)=vl_from_block(1) + lvlv_mean(ib)=vl_from_block(2) + lvle_mean(ib)=vl_from_block(3) + lvlb_mean(ib)=vl_from_block(4) + + lastsubstep = .false. + if( real(istep) > real(step_per_day)*calving_day(ib) ) then !iceberg calved + + !substeps don't work anymore with new communication + lastsubstep = .true. !do output every timestep + + if( .not.melted(ib) ) then + call iceberg_step2(mesh, partit, arr_from_block, elem_from_block, ib, height_ib(ib),length_ib(ib),width_ib(ib), lon_deg(ib),lat_deg(ib),& + Co(ib),Ca(ib),Ci(ib), Cdo_skin(ib),Cda_skin(ib), rho_icb(ib), & + conc_sill(ib),P_sill(ib), rho_h2o(ib),rho_air(ib),rho_ice(ib), & + u_ib(ib),v_ib(ib), iceberg_elem(ib), find_iceberg_elem(ib), lastsubstep,& + f_u_ib_old(ib), f_v_ib_old(ib), l_semiimplicit, & + semiimplicit_coeff, AB_coeff, istep) + end if + end if +end do + + t3=MPI_Wtime() + + + !========================== VECTOR OUTPUT =============================! + + !call iceberg_vector_ncout !look in routines what is really written out! + !istep, lon_deg_geo, lat_deg_geo, u_ib_geo, v_ib_geo, volume losses (set to zero) + !introduce force_last_output(ib)? + + if (mod(istep_end_synced,icb_outfreq)==0 .AND. .not.ascii_out) then + + if (mype==0 .AND. (real(istep) > real(step_per_day)*calving_day(1) ) ) call write_buoy_props_netcdf(partit) + + ! all PEs: set back to zero for next round + bvl_mean=0.0 + lvlv_mean=0.0 + lvle_mean=0.0 + lvlb_mean=0.0 + + end if + + t4=MPI_Wtime() + + if (mod(istep,logfile_outfreq)==0 .and. mype==0) then + write(*,*) 'icebergs took', t4-t0 + write(*,*) 'iceberg step1 took', t1-t0 + write(*,*) 'NEW comvalues took', t2-t1 + write(*,*) 'iceberg step2 took', t3-t2 + write(*,*) 'vector output took', t4-t3 + write(*,*) 'reading restart took', t1_restart-t0_restart + write(*,*) '*************************************************************' + end if +end subroutine iceberg_calculation + + +!**************************************************************************************************************************** +!**************************************************************************************************************************** + + +subroutine iceberg_step1(ice, mesh, partit, dynamics, ib, height_ib,length_ib,width_ib, lon_deg,lat_deg, & + Co,Ca,Ci, Cdo_skin,Cda_skin, rho_icb, & + conc_sill,P_sill, rho_h2o,rho_air,rho_ice, & + u_ib,v_ib, iceberg_elem, find_iceberg_elem, & + lastsubstep, f_u_ib_old, & + f_v_ib_old, l_semiimplicit, semiimplicit_coeff, & + AB_coeff, istep) + + !============================= MODULES & DECLARATIONS =========================================!= + != + use o_param !for rad != + use g_rotate_grid !for subroutine g2r, logfile_outfreq != + use g_config, only: steps_per_ib_step + != +!#ifdef use_cavity +! use iceberg_params, only: smallestvol_icb, arr_block, elem_block, l_geo_out, icb_outfreq, l_allowgrounding, draft_scale, reject_elem, melted, grounded, scaling !, length_ib, width_ib, scaling +!#else +! use iceberg_params, only: smallestvol_icb, arr_block, elem_block, l_geo_out, icb_outfreq, l_allowgrounding, draft_scale, melted, grounded, scaling !, length_ib, width_ib, scaling +!#endif + != + implicit none != + + + integer, intent(in) :: ib, istep + real, intent(inout) :: height_ib,length_ib,width_ib + real, intent(inout) :: lon_deg,lat_deg + real, intent(in) :: Co,Ca,Ci, Cdo_skin,Cda_skin + real, intent(in) :: rho_icb, conc_sill,P_sill, rho_h2o,rho_air,rho_ice + real, intent(inout) :: u_ib,v_ib + integer, intent(inout) :: iceberg_elem !global + logical, intent(inout) :: find_iceberg_elem + logical, intent(in) :: lastsubstep + real, intent(inout) :: f_u_ib_old, f_v_ib_old + logical, intent(in) :: l_semiimplicit + real, intent(in) :: semiimplicit_coeff + real, intent(in) :: AB_coeff + real, dimension(:), pointer :: coriolis + integer :: istep_end_synced + + integer, dimension(:), save, allocatable :: local_idx_of + real :: depth_ib, volume_ib, mass_ib + real :: lon_rad, lat_rad, new_u_ib, new_v_ib + real :: old_lon,old_lat, frozen_in, P_ib, conci_ib + real :: lon_rad_out, lat_rad_out !for unrotated output + real :: lon_deg_out, lat_deg_out !for unrotated output + integer :: i, iceberg_node + real :: dudt, dvdt +!! LA: add threshold for number of icebergs in one elemt + integer :: num_ib_in_elem, idx + real :: area_ib_tot + + !iceberg output + character :: ib_char*10 + character :: file_track*80 + character :: file_forces_u*80 + character :: file_forces_v*80 + character :: file_meltrates*80 + logical :: l_output + + !MPI + real :: arr(15) != + logical :: i_have_element != + real :: left_mype != + integer :: old_element != + real(kind=8) :: t0, t1, t2, t3, t4, t5, t6, t7, t8 != + != + !for restart != + logical, save :: firstcall=.true. != + !for grounding != + real, dimension(3) :: Zdepth3 != + real :: Zdepth != + != + real, dimension(2) :: coords_tmp +! integer, pointer :: mype + +type(t_ice), intent(inout), target :: ice +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +type(t_dyn) , intent(inout), target :: dynamics +!========================= MODULES & DECLARATIONS =====================================!= +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + mype =>partit%mype + + istep_end_synced = istep + steps_per_ib_step - 1 + + depth_ib = -height_ib * rho_icb/rho_h2o + volume_ib= length_ib * width_ib * height_ib + mass_ib = volume_ib * rho_icb !less mass + lon_rad = lon_deg*rad + lat_rad = lat_deg*rad + + if(volume_ib .le. smallestvol_icb) then + melted(ib) = .true. + + if (mod(istep_end_synced,logfile_outfreq)==0 .and. mype==0 .and. lastsubstep) then + write(*,*) 'iceberg ', ib,' melted' + end if + + return + end if + + if (firstcall) then + if(mype==0) write(*,*) 'Preparing local_idx_of array...' + allocate(local_idx_of(elem2D)) + !creates mapping + call global2local(mesh, partit, local_idx_of, elem2D) + firstcall=.false. + if(mype==0) write(*,*) 'Preparing local_idx_of done.' + end if + + if (find_iceberg_elem) then + lon_rad = lon_deg*rad + lat_rad = lat_deg*rad + call g2r(lon_rad, lat_rad, lon_rad, lat_rad) + lat_deg=lat_rad/rad !rotated lat in degree + lon_deg=lon_rad/rad !rotated lon in degree + + !find LOCAL element where the iceberg starts: + coords_tmp = [lon_deg, lat_deg] + call point_in_triangle(mesh, partit, iceberg_elem, coords_tmp) + !call point_in_triangle(mesh, iceberg_elem, (/lon_deg, lat_deg/)) + i_have_element= (iceberg_elem .ne. 0) !up to 3 PEs possible + + if(i_have_element) then + i_have_element= mesh%elem2D_nodes(1,iceberg_elem) <= partit%myDim_nod2D !1 PE still .true. +#ifdef use_cavity + if(reject_elem(mesh, partit, iceberg_elem)) then + iceberg_elem=0 !reject element + i_have_element=.false. + else + iceberg_elem=partit%myList_elem2D(iceberg_elem) !global now + end if +#else + + iceberg_elem=partit%myList_elem2D(iceberg_elem) !global now +#endif + end if + call com_integer(partit, i_have_element,iceberg_elem) + + if(iceberg_elem .EQ. 0) then + write(*,*) 'IB ',ib,' rot. coords:', lon_deg, lat_deg !,lon_rad, lat_rad + call par_ex + stop 'ICEBERG OUTSIDE MODEL DOMAIN OR IN ICE SHELF REGION' + end if + + ! initialize the iceberg velocity + call initialize_velo(mesh, partit, dynamics, i_have_element, ib, u_ib, v_ib, lon_rad, lat_rad, depth_ib, local_idx_of(iceberg_elem)) + + !iceberg elem of ib is found + find_iceberg_elem = .false. + + coriolis => mesh%coriolis(:) + !for AB method + +! kh 06.08.21 observed via -check bounds: forrtl: severe (408): fort: (3): Subscript #1 of the array CORIOLIS has value 0 which is less than the lower bound of 1 + if(local_idx_of(iceberg_elem) > 0) then + if(local_idx_of(iceberg_elem) <= partit%myDim_elem2D ) then + + f_u_ib_old = coriolis(local_idx_of(iceberg_elem))*u_ib + f_v_ib_old = coriolis(local_idx_of(iceberg_elem))*v_ib + + endif + endif + end if + + + ! ================== START ICEBERG CALCULATION ==================== + + arr=0. + frozen_in = 0. + i_have_element=.false. + !if the first node belongs to this processor.. (just one processor enters here!) + !if( local_idx_of(iceberg_elem) > 0 .and. elem2D_nodes(1,local_idx_of(iceberg_elem)) <= myDim_nod2D ) then +if( local_idx_of(iceberg_elem) > 0 ) then + if( elem2D_nodes(1,local_idx_of(iceberg_elem)) <= partit%myDim_nod2D ) then + + i_have_element=.true. + +! kh 16.03.21 (asynchronous) iceberg calculation starts with the content in common arrays at istep and will merge its results at istep_end_synced +! l_output = lastsubstep .and. mod(istep,icb_outfreq)==0 + l_output = lastsubstep .and. mod(istep_end_synced,icb_outfreq)==0 + + !===========================DYNAMICS=============================== + + + call iceberg_dyn(mesh, partit, ice, dynamics, ib, new_u_ib, new_v_ib, u_ib, v_ib, lon_rad,lat_rad, depth_ib, & + height_ib, length_ib, width_ib, local_idx_of(iceberg_elem), & + mass_ib, Ci, Ca, Co, Cda_skin, Cdo_skin, & + rho_ice, rho_air, rho_h2o, P_sill,conc_sill, frozen_in, & + file_forces_u, file_forces_v, P_ib, conci_ib, & + dt*REAL(steps_per_ib_step), l_output, f_u_ib_old, & + f_v_ib_old, l_semiimplicit, semiimplicit_coeff, & + AB_coeff, file_meltrates, rho_icb) + call prepare_icb2fesom(mesh,partit,ib,i_have_element,local_idx_of(iceberg_elem),depth_ib) + + dudt = (new_u_ib-u_ib)/REAL(steps_per_ib_step) / dt + dvdt = (new_v_ib-v_ib)/REAL(steps_per_ib_step) / dt + + !=======================END OF DYNAMICS============================ + + call depth_bathy(mesh,partit, Zdepth3, local_idx_of(iceberg_elem)) + !interpolate depth to location of iceberg (2 times because FEM_3eval expects a 2 component vector...) + call FEM_3eval(mesh,partit, Zdepth,Zdepth,lon_rad,lat_rad,Zdepth3,Zdepth3,local_idx_of(iceberg_elem)) + !write(*,*) 'nodal depth in iceberg ', ib,'s element:', Zdepth3 + !write(*,*) 'depth at iceberg ', ib, 's location:', Zdepth + + !=================CHECK IF ICEBERG IS GROUNDED...=================== + if((draft_scale(ib)*abs(depth_ib) .gt. Zdepth) .and. l_allowgrounding ) then + !if((draft_scale(ib)*abs(depth_ib) .gt. minval(Zdepth3)) .and. l_allowgrounding ) then + !icebergs remains stationary (iceberg can melt above in iceberg_dyn!) + left_mype = 0.0 + u_ib = 0.0 + v_ib = 0.0 + old_lon = lon_rad + old_lat = lat_rad + + !!########################################### + !! LA: prevent too many icebergs in one element + old_element = iceberg_elem !save if iceberg left model domain + !!########################################### + +! kh 16.03.21 (asynchronous) iceberg calculation starts with the content in common arrays at istep and will merge its results at istep_end_synced + if (mod(istep_end_synced,logfile_outfreq)==0) then + write(*,*) 'iceberg ib ', ib, 'is grounded' + grounded(ib) = .true. + end if + + else + !===================...ELSE CALCULATE TRAJECTORY==================== + + ! LA: prevent too many icebergs in one element + old_element = iceberg_elem !save if iceberg left model domain + + t0=MPI_Wtime() + call trajectory( lon_rad,lat_rad, u_ib,v_ib, new_u_ib,new_v_ib, & + lon_deg,lat_deg,old_lon,old_lat, dt*REAL(steps_per_ib_step)) + + t1=MPI_Wtime() + iceberg_elem=local_idx_of(iceberg_elem) !local + + t2=MPI_Wtime() + call find_new_iceberg_elem(mesh, partit, iceberg_elem, [lon_deg, lat_deg], left_mype) + t3=MPI_Wtime() + iceberg_elem=partit%myList_elem2D(iceberg_elem) !global + + if(left_mype > 0.) then + lon_rad = old_lon + lat_rad = old_lat + t4=MPI_Wtime() + call parallel2coast(mesh,partit, new_u_ib, new_v_ib, lon_rad,lat_rad, local_idx_of(iceberg_elem)) + t5=MPI_Wtime() + call trajectory( lon_rad,lat_rad, new_u_ib,new_v_ib, new_u_ib,new_v_ib, & + lon_deg,lat_deg,old_lon,old_lat, dt*REAL(steps_per_ib_step)) + t6=MPI_Wtime() + u_ib = new_u_ib + v_ib = new_v_ib + + iceberg_elem=local_idx_of(iceberg_elem) !local + t7=MPI_Wtime() + call find_new_iceberg_elem(mesh,partit, iceberg_elem, (/lon_deg, lat_deg/), left_mype) + t8=MPI_Wtime() + iceberg_elem=partit%myList_elem2D(iceberg_elem) !global + end if + !================END OF TRAJECTORY CALCULATION===================== + end if ! iceberg stationary? + + !----------------------------- + ! LA 2022-11-30 + do idx = 1, size(elem_block) + if (elem_block(idx) == iceberg_elem) then + area_ib_tot = area_ib_tot + length_ib * width_ib * scaling(idx) + end if + end do + !----------------------------- + + if((area_ib_tot > elem_area(local_idx_of(iceberg_elem))) .and. & + (iceberg_elem .ne. old_element) .and. & + (old_element .ne. 0) .and. & + (.not.grounded(ib))) then + lon_rad = old_lon + lat_rad = old_lat + lon_deg = lon_rad/rad + lat_deg = lat_rad/rad + iceberg_elem = old_element + u_ib = 0. + v_ib = 0. + end if + !########################################### + + !values for communication + arr= (/ height_ib,length_ib,width_ib, u_ib,v_ib, lon_rad,lat_rad, & + left_mype, old_lon,old_lat, frozen_in, dudt, dvdt, P_ib, conci_ib/) + + !save in larger array + arr_block((ib-1)*15+1 : ib*15)=arr + elem_block(ib)=iceberg_elem + + end if !processor has element? +end if !... and first node belongs to processor? + + !t1=MPI_Wtime() + !if (mod(istep,logfile_outfreq)==0 .and. i_have_element .and. lastsubstep) write(*,*) 'dynamics took', t1-t0 + !if (mod(istep,logfile_outfreq)==0 .and. i_have_element .and. lastsubstep) then + ! write(*,*) 'trajectory 1 took', t1-t0 + ! write(*,*) 'find_new_iceberg_elem 1 took', t3-t2 + ! write(*,*) 'parallel2coast took', t5-t4 + ! write(*,*) 'trajectory 2 took', t6-t5 + ! write(*,*) 'find_new_iceberg_elem 2 took', t8-t7 + !end if + ! =================== END OF ICEBERG CALCULATION ================== + + end subroutine iceberg_step1 + +subroutine get_total_iceberg_area(mesh, partit,iceberg_elem, area_ib_tot) + + use o_param !for rad != + USE MOD_MESH + use MOD_PARTIT !for myDim_elem2D, myList_nod2D != + use g_rotate_grid !for subroutine g2r, logfile_outfreq != + !use iceberg_params, only: arr_block, elem_block, length_ib, width_ib, scaling + + implicit none != + + integer, intent(inout) :: iceberg_elem !global + real, intent(inout) :: area_ib_tot + integer :: idx + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +!========================= MODULES & DECLARATIONS =====================================!= +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + area_ib_tot = 0.0 + do idx = 1, size(elem_block) + if (elem_block(idx) == iceberg_elem) then + area_ib_tot = area_ib_tot + length_ib(idx) * width_ib(idx) * scaling(idx) + end if + end do + !########################################### +end subroutine get_total_iceberg_area + + +subroutine iceberg_step2(mesh, partit,arr, elem_from_block, ib, height_ib,length_ib,width_ib, lon_deg,lat_deg, & + Co,Ca,Ci, Cdo_skin,Cda_skin, rho_icb, & + conc_sill,P_sill, rho_h2o,rho_air,rho_ice, & + u_ib,v_ib, iceberg_elem, find_iceberg_elem, & + lastsubstep, f_u_ib_old, & + f_v_ib_old, l_semiimplicit, semiimplicit_coeff, & + AB_coeff, istep) + + !============================= MODULES & DECLARATIONS =========================================!= + != + use o_param !for rad != + use g_rotate_grid !for subroutine g2r, logfile_outfreq != + use g_config, only: steps_per_ib_step +!= +!#ifdef use_cavity +! use iceberg_params, only: smallestvol_icb, buoy_props, bvl_mean, lvlv_mean, lvle_mean, lvlb_mean, ascii_out, l_geo_out, icb_outfreq, l_allowgrounding, draft_scale, reject_elem, elem_block +!#else +! use iceberg_params, only: smallestvol_icb, buoy_props, bvl_mean, lvlv_mean, lvle_mean, lvlb_mean, ascii_out, l_geo_out, icb_outfreq, l_allowgrounding, draft_scale, elem_block +!#endif + != + implicit none != + + real, intent(in) :: arr(15) + integer, intent(in) :: elem_from_block + integer, intent(in) :: ib + real, intent(inout) :: height_ib,length_ib,width_ib + real, intent(inout) :: lon_deg,lat_deg + real, intent(in) :: Co,Ca,Ci, Cdo_skin,Cda_skin + real, intent(in) :: rho_icb, conc_sill,P_sill, rho_h2o,rho_air,rho_ice + real, intent(inout) :: u_ib,v_ib + integer, intent(inout) :: iceberg_elem !global + logical, intent(inout) :: find_iceberg_elem + logical, intent(in) :: lastsubstep + real, intent(inout) :: f_u_ib_old, f_v_ib_old + logical, intent(in) :: l_semiimplicit + real, intent(in) :: semiimplicit_coeff + real, intent(in) :: AB_coeff + + + integer, dimension(:), save, allocatable :: local_idx_of + real :: depth_ib, volume_ib, mass_ib + real :: lon_rad, lat_rad, new_u_ib, new_v_ib + real :: old_lon,old_lat, frozen_in, P_ib, conci_ib + real :: lon_rad_out, lat_rad_out !for unrotated output + real :: lon_deg_out, lat_deg_out !for unrotated output + real :: u_ib_out, v_ib_out !for unrotated output + real :: dudt_out, dvdt_out !for unrotated output + integer :: i, iceberg_node, istep + real :: dudt, dvdt + +! kh 16.03.21 + integer :: istep_end_synced + +! LA: add threshold for number of icebergs in one elemt + integer :: num_ib_in_elem, idx + real :: area_ib_tot + real :: local_elem_area + + !iceberg output + character :: ib_char*10 + character :: file_track*80 + character :: file_forces_u*80 + character :: file_forces_v*80 + character :: file_meltrates*80 + logical :: l_output + + !MPI + logical :: i_have_element != + real :: left_mype != + integer :: old_element != + real(kind=8) :: t0, t1, t2, t3, t4 != + != + !for restart != + logical, save :: firstcall=.true. != + !for grounding != + real, dimension(3) :: Zdepth3 != + real :: Zdepth != + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit + !========================= MODULES & DECLARATIONS =====================================!= +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + !all PEs enter here with identical array arr + + !**** check if iceberg melted in step 1 ****! + !mass_ib = arr(1) * arr(2) * arr(3) * rho_icb + !if(mass_ib .le. 1.0e-6) then + ! return + !end if + + !**** check if iceberg melted in step 1 ****! + !call com_values(i_have_element, arr, iceberg_elem) + +! kh 16.03.21 (asynchronous) iceberg calculation starts with the content in common arrays at istep and will merge its results at istep_end_synced + istep_end_synced = istep + steps_per_ib_step - 1 + + iceberg_elem= elem_from_block !update element as before in com_values + old_element = elem_from_block !save if iceberg left model domain + height_ib= arr(1) + length_ib= arr(2) + width_ib = arr(3) + u_ib = arr(4) + v_ib = arr(5) + lon_rad = arr(6) + lat_rad = arr(7) + lon_deg = lon_rad/rad + lat_deg = lat_rad/rad + left_mype= arr(8) + old_lon = arr(9) + old_lat = arr(10) + frozen_in= arr(11) + dudt = arr(12) + dvdt = arr(13) + P_ib = arr(14) + conci_ib = arr(15) + + !**** check if iceberg melted in step 1 ****! + volume_ib = height_ib * length_ib * width_ib ! * rho_icb + if(volume_ib .le. smallestvol_icb) then + buoy_props(ib, :) = 0. ! for output: NaN or MissVal could be written here + return + end if + !**** check if iceberg melted in step 1 ****! + + t2=MPI_Wtime() + + !!**** LA: check if iceberg changed element and new element is too full + !!if(local_idx_of(iceberg_elem) > 0 .and. iceberg_elem .ne. old_element) then !IB left model domain + !if(iceberg_elem .ne. old_element) then + if (firstcall) then + allocate(local_idx_of(elem2D)) + !creates mapping + call global2local(mesh, partit, local_idx_of, elem2D) + firstcall=.false. + end if + + if(left_mype > 0.) then + call iceberg_elem4all(mesh, partit, iceberg_elem, lon_deg, lat_deg) !Just PE changed? + if(iceberg_elem == 0 ) then + lon_rad = old_lon + lat_rad = old_lat + lon_deg = lon_rad/rad + lat_deg = lat_rad/rad + iceberg_elem = old_element + u_ib = 0. + v_ib = 0. + else + if (mype==0) write(*,*) 'iceberg ',ib, ' changed PE or was very fast' + call get_total_iceberg_area(mesh, partit, iceberg_elem, area_ib_tot) + if(area_ib_tot > elem_area(local_idx_of(iceberg_elem))) then + lon_rad = old_lon + lat_rad = old_lat + lon_deg = lon_rad/rad + lat_deg = lat_rad/rad + iceberg_elem = old_element + u_ib = 0. + v_ib = 0. + end if + end if + end if + + t3=MPI_Wtime() + + + !if(mype==0 .and. lastsubstep .and. mod(istep,icb_outfreq)==0 .and. ascii_out) then + !if(mype==mod(ib,npes-1) .and. lastsubstep .and. mod(istep,icb_outfreq)==0 .and. ascii_out) then + +! kh 16.03.21 (asynchronous) iceberg calculation starts with the content in common arrays at istep and will merge its results at istep_end_synced +! if(mype==0 .and. lastsubstep .and. mod(istep,icb_outfreq)==0) then + if(mype==0 .and. lastsubstep .and. mod(istep_end_synced,icb_outfreq)==0) then + + !output in 1. unrotated or 2. rotated coordinates + u_ib_out = u_ib + v_ib_out = v_ib + dudt_out = dudt + dvdt_out = dvdt + if(l_geo_out) then + call r2g(lon_rad_out, lat_rad_out, lon_rad, lat_rad) + lon_deg_out = lon_rad_out/rad + lat_deg_out = lat_rad_out/rad + call vector_r2g(u_ib_out, v_ib_out, lon_rad, lat_rad, 0) + call vector_r2g(dudt_out, dvdt_out, lon_rad, lat_rad, 0) + else + lon_rad_out = lon_rad + lat_rad_out = lat_rad + lon_deg_out = lon_deg + lat_deg_out = lat_deg + end if + +! if(ascii_out) then !use old ASCII output +! +! file_track='/work/ollie/lackerma/iceberg/iceberg_ICBref_' +! !convert ib integer to string +! write(ib_char,'(I10)') ib +! !left-adjust the string.. +! ib_char = adjustl(ib_char) +! !.. and trim while concatenating: +! file_track = trim(file_track) // trim(ib_char) // '.dat' +! +! open(unit=42,file=file_track,position='append') +! +!! kh 16.03.21 (asynchronous) iceberg calculation starts with the content in common arrays at istep and will merge its results at istep_end_synced +!! write(42,'(I,12e15.7)') istep, lon_rad_out, lat_rad_out, lon_deg_out, lat_deg_out, & +!! u_ib_out, v_ib_out, frozen_in, P_sill, P_ib, conci_ib, dudt_out, dvdt_out +! write(42,'(I,12e15.7)') istep_end_synced, lon_rad_out, lat_rad_out, lon_deg_out, lat_deg_out, & +! u_ib_out, v_ib_out, frozen_in, P_sill, P_ib, conci_ib, dudt_out, dvdt_out +! close(42) +! +! else !write in array for faster netcdf output + + buoy_props(ib, 1) = lon_rad_out + buoy_props(ib, 2) = lat_rad_out + buoy_props(ib, 3) = lon_deg_out + buoy_props(ib, 4) = lat_deg_out + buoy_props(ib, 5) = frozen_in + buoy_props(ib, 6) = dudt_out + buoy_props(ib, 7) = dvdt_out + buoy_props(ib, 8) = u_ib_out + buoy_props(ib, 9) = v_ib_out + buoy_props(ib,10) = height_ib + buoy_props(ib,11) = length_ib + buoy_props(ib,12) = width_ib + buoy_props(ib,13) = iceberg_elem + +! end if + + end if + + t4=MPI_Wtime() + +! if (mod(istep,logfile_outfreq)==0 .and. mype==0 .and. lastsubstep) then +! write(*,*) '*** step2 ***' +! write(*,*) 'comvalues took', t2-t1 +! write(*,*) 'left mype took', t3-t2 +! write(*,*) 'track out took', t4-t3 +! end if + +end subroutine iceberg_step2 + + +!**************************************************************************************************************************** +!**************************************************************************************************************************** + +subroutine initialize_velo(mesh,partit,dynamics, i_have_element, ib, u_ib, v_ib, lon_rad, lat_rad, depth_ib, localelem) + + use g_rotate_grid, only: vector_g2r +! use iceberg_params, only: l_initial, l_iniuser, ini_u, ini_v +implicit none + + logical, intent(in) :: i_have_element + integer, intent(in) :: ib + real, intent(inout) :: u_ib, v_ib + real, intent(in) :: lon_rad, lat_rad, depth_ib + integer, intent(in) :: localelem + + real, dimension(3) :: startu, startv + real :: ini_u_rot, ini_v_rot + +type(t_mesh), intent(in) , target :: mesh +type(t_dyn), intent(in) , target :: dynamics +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + + + !initialize ZERO for all PEs + u_ib=0. + v_ib=0. + + !use initial velocities? + if(l_initial .AND. i_have_element) then + + if(l_iniuser) then + ini_u_rot = ini_u(ib) !still in geo. coord. + ini_v_rot = ini_v(ib) !still in geo. coord. + call vector_g2r(ini_u_rot, ini_v_rot, lon_rad, lat_rad, 0) + u_ib = ini_u_rot + v_ib = ini_v_rot + else + !OCEAN VELOCITY uo_ib, voib is start velocity + call iceberg_avvelo(mesh, partit, dynamics, startu,startv,depth_ib,localelem) + call FEM_3eval(mesh, partit,u_ib,v_ib,lon_rad,lat_rad,startu,startv,localelem) + end if + end if + +end subroutine initialize_velo + + +!**************************************************************************************************************************** +!**************************************************************************************************************************** + +subroutine trajectory( lon_rad,lat_rad, old_u,old_v, new_u,new_v, & + lon_deg,lat_deg,old_lon,old_lat, dt_ib ) + use o_param !for dt, r_earth + implicit none + + real, intent(inout) :: lon_rad,lat_rad + real, intent(inout) :: old_u,old_v + real, intent(in) :: new_u,new_v + real, intent(out) :: lon_deg,lat_deg,old_lon,old_lat + real, intent(in) :: dt_ib + + real :: deltax1, deltay1, deltax2, deltay2 + + !save old position in case the iceberg leaves the domain + old_lon = lon_rad + old_lat = lat_rad + + !displacement vectors + deltax1 = old_u * dt_ib + deltay1 = old_v * dt_ib + deltax2 = new_u * dt_ib + deltay2 = new_v * dt_ib + + !heun method + lon_rad = lon_rad + (0.5*(deltax1 + deltax2) / (r_earth*cos(lat_rad)) ) + lat_rad = lat_rad + (0.5*(deltay1 + deltay2) / r_earth ) + lon_deg=lon_rad/rad + lat_deg=lat_rad/rad + + !update velocity here (old value was needed for heun method) + old_u=new_u + old_v=new_v + +end subroutine trajectory + + +!**************************************************************************************************************************** +!**************************************************************************************************************************** + +subroutine depth_bathy(mesh, partit,Zdepth3, elem) + use o_param + use g_clock + use g_forcing_arrays + use g_rotate_grid + + implicit none + + real, dimension(3), intent(OUT) :: Zdepth3 !depth in column below element + integer, intent(IN) :: elem !local element + integer :: m, n2, k, n_low + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + Zdepth3=0.0 + + ! loop over all nodes of the iceberg element + do m=1, 3 + !for each 2D node of the iceberg element.. + n2=mesh%elem2D_nodes(m,elem) + + !k=num_layers_below_nod2d(n2)+1 + !n_low= nod3d_below_nod2d(k, n2) !deepest node below n2 + k=mesh%nlevels_nod2D(n2) + + !..compute depth below this node: + !Zdepth3(m) = abs(coord_nod3D(3, n_low)) + !Zdepth3(m) = abs(mesh%Z_3d_n_ib(k, n2)) + Zdepth3(m) = abs(mesh%zbar_n_bot(n2)) + !Zdepth3(m) = abs(mesh%zbar(k)) + !if (!Zdepth3(m)<0.0) then + ! Zdepth3(m) = -Zdepth3(m) + !end if + end do + +end subroutine depth_bathy + + +!**************************************************************************************************************************** +!**************************************************************************************************************************** + +subroutine parallel2coast(mesh, partit,u, v, lon,lat, elem) +!#ifdef use_cavity +! use iceberg_params, only: coastal_nodes +!#endif + implicit none + + real, intent(inout) :: u, v !velocity + real, intent(in) :: lon, lat !radiant + integer, intent(in) :: elem + + integer, dimension(3) :: n + integer :: node, m, i + real, dimension(2) :: velocity, velocity1, velocity2 + real :: d1, d2 + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + +#ifdef use_cavity + SELECT CASE ( coastal_nodes(mesh, elem) ) !num of "coastal" points +#else + SELECT CASE ( sum( mesh%bc_index_nod2D(mesh%elem2D_nodes(:,elem)) ) ) !num of coastal points + !SELECT CASE ( sum( bc_index_nod2D(elem2D_nodes(:,elem)) ) ) !num of coastal points +#endif + CASE (0) !...coastal points: do nothing + return + + CASE (1) !...coastal point + n = 0 + i = 1 + velocity = [ u, v ] + do m = 1, 3 + node = mesh%elem2D_nodes(m,elem) + !write(*,*) 'index ', m, ':', index_nod2D(node) +#ifdef use_cavity + if( mesh%bc_index_nod2D(node)==1 .OR. cavity_flag_nod2d(node)==1 ) then +#else + if( mesh%bc_index_nod2D(node)==1 ) then +#endif + n(i) = node + exit + end if + end do + + !write(*,*) 'one coastal node ', n(1) + + !LA comment for testing + !i = 2 + !if ( n(1) <= myDim_nod2D ) then !all neighbours known + + ! do m = 1, nghbr_nod2D(n(1))%nmb + ! node = nghbr_nod2D(n(1))%addresses(m) +!#ifdef use_cavity + ! if ( (node /= n(1)) .and. ( (bc_index_nod2D(node)==1) .OR. (cavity_flag_nod2d(node)==1) ) ) then +!#else + ! if ( (node /= n(1)) .and. (bc_index_nod2D(node)==1)) then +!#endif + ! n(i) = node + ! i = i+1 + ! if(i==4) exit + ! end if + ! end do + + !write(*,*) 'nodes n(i) ', n + + d1 = sqrt( (lon - coord_nod2D(1, n(2)))**2 + (lat - coord_nod2D(2, n(2)))**2 ) + d2 = sqrt( (lon - coord_nod2D(1, n(3)))**2 + (lat - coord_nod2D(2, n(3)))**2 ) + !write(*,*) 'distances :' , d1, d2 + !write(*,*) 'velocity vor :' , velocity + if (d1 < d2) then + call projection(mesh,partit, velocity, n(2), n(1)) + else + call projection(mesh,partit, velocity, n(3), n(1)) + end if + !write(*,*) 'velocity nach:', velocity + !call projection(velocity, n(3), n(2)) + + !else + ! !if coastal point is not first node of element, the coastal point could be in eDim_nod2D, + ! !so not all neighbours of this node are known to PE. WHAT SHOULD BE DONE? + !end if + + + CASE (2) !...coastal points + n = 0 + i = 1 + velocity = [ u, v ] + do m = 1, 3 + node = mesh%elem2D_nodes(m,elem) +#ifdef use_cavity + if( (mesh%bc_index_nod2D(node)==1) .OR. (cavity_flag_nod2d(node)==1)) then +#else + if( mesh%bc_index_nod2D(node)==1 ) then +#endif + n(i) = node + i = i+1 + end if + end do + call projection(mesh,partit, velocity, n(1), n(2)) + + + CASE DEFAULT + return !mesh element MUST NOT have 3 coastal points! + + END SELECT + + u = velocity(1) + v = velocity(2) + +end subroutine parallel2coast + + +!**************************************************************************************************************************** +!**************************************************************************************************************************** + + +subroutine projection(mesh, partit, velocity, n1, n2) +implicit none + + real, dimension(2), intent(inout) :: velocity + integer, intent(in) :: n1, n2 + + real, dimension(2) :: direction + real :: length, sp + +type(t_mesh), intent(in) , target :: mesh +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + ! direction: node1 - node2 (pointing from 2 to 1) + direction(1) = coord_nod2D(1, n1) - coord_nod2D(1, n2) + direction(2) = coord_nod2D(2, n1) - coord_nod2D(2, n2) + length = sqrt( direction(1)**2 + direction(2)**2 ) + direction(1) = direction(1)/length + direction(2) = direction(2)/length + + sp = sum( velocity(:) * direction(:) ) !ab = b'|a|, b' scalar projection of vec b on vec a + velocity = sp * direction + +end subroutine projection + + +!**************************************************************************************************************************** +!**************************************************************************************************************************** + + +subroutine iceberg_restart(partit) +! use iceberg_params + use g_config, only : ib_num + + implicit none + integer :: icbID, ib + LOGICAL :: file_exists +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_part_ass.h" + INQUIRE(FILE=IcebergRestartPath, EXIST=file_exists) + icbID = mype+10 + + !call allocate_icb + + if(file_exists) then + open(unit=icbID,file=IcebergRestartPath,status='old', form='formatted') + + do ib=1, ib_num + + !read all parameters that icb_step needs: + read(icbID,'(18e15.7,I8,L,3e15.7,L,I5,L)') & + height_ib(ib),length_ib(ib),width_ib(ib), lon_deg(ib),lat_deg(ib), & + Co(ib),Ca(ib),Ci(ib), Cdo_skin(ib),Cda_skin(ib), rho_icb(ib), & + conc_sill(ib),P_sill(ib), rho_h2o(ib),rho_air(ib),rho_ice(ib), & + u_ib(ib),v_ib(ib), iceberg_elem(ib), find_iceberg_elem(ib), & + f_u_ib_old(ib), f_v_ib_old(ib), calving_day(ib), grounded(ib), scaling(ib), melted(ib) + + end do + close(icbID) + + if(mype==0) then + write(*,*) 'read iceberg restart file' + + !if(.NOT.ascii_out) call determine_save_count ! computed from existing records in netcdf file + if(.NOT.ascii_out) call init_buoy_output(partit) + !call init_icebergs_with_icesheet ! all PEs read LON,LAT,LENGTH from files + + !write(*,*) '*************************************************************' + end if + else + + if(mype==0) then + write(*,*) 'no iceberg restart' + + if(.NOT.ascii_out) call init_buoy_output(partit) + + end if + + !call init_buoys ! all PEs read LON,LAT from files + !write(*,*) 'initialized positions from file' + call init_icebergs ! all PEs read LON,LAT,LENGTH from files + !write(*,*) 'initialized positions and length/width from file' + !write(*,*) '*************************************************************' + end if + +end subroutine iceberg_restart + + +!**************************************************************************************************************************** +!**************************************************************************************************************************** + + +subroutine iceberg_restart_with_icesheet(partit) +! use iceberg_params + use g_config, only : ib_num + + implicit none + integer :: icbID_ISM, icbID_non_melted_icb, ib, st + LOGICAL :: file_exists, file_exists_non_melted +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_part_ass.h" + + INQUIRE(FILE=num_non_melted_icb_file, EXIST=file_exists_non_melted) + INQUIRE(FILE=IcebergRestartPath_ISM, EXIST=file_exists) + icbID_ISM = mype+10 + icbID_non_melted_icb = mype+11 + + !call allocate_icb + + open(unit=icbID_non_melted_icb,file=num_non_melted_icb_file,status='old', form='formatted') + read(icbID_non_melted_icb,*) num_non_melted_icb + close(icbID_non_melted_icb) + + if(file_exists) then + open(unit=icbID_ISM,file=IcebergRestartPath_ISM,status='old', form='formatted') + do ib=1, num_non_melted_icb + !read all parameters that icb_step needs: + read(icbID_ISM,'(18e15.7,I8,L,3e15.7,L,I5,L)',iostat=st) & + height_ib(ib),length_ib(ib),width_ib(ib), lon_deg(ib),lat_deg(ib), & + Co(ib),Ca(ib),Ci(ib), Cdo_skin(ib),Cda_skin(ib), rho_icb(ib), & + conc_sill(ib),P_sill(ib), rho_h2o(ib),rho_air(ib),rho_ice(ib), & + u_ib(ib),v_ib(ib), iceberg_elem(ib), find_iceberg_elem(ib), & + f_u_ib_old(ib), f_v_ib_old(ib), calving_day(ib), grounded(ib), scaling(ib), melted(ib) + end do + close(icbID_ISM) + + if(mype==0) then + write(*,*) 'read iceberg restart file' + + !if(.NOT.ascii_out) call determine_save_count ! computed from existing records in netcdf file + if(.NOT.ascii_out) call init_buoy_output(partit) + end if + call init_icebergs_with_icesheet + !write(*,*) 'initialized positions and length/width from file' + !write(*,*) '*************************************************************' + else + + if(mype==0) then + write(*,*) 'no iceberg restart' + + if(.NOT.ascii_out) call init_buoy_output(partit) + + end if + + !call init_buoys ! all PEs read LON,LAT from files + !write(*,*) 'initialized positions from file' + call init_icebergs !_with_icesheet ! all PEs read LON,LAT,LENGTH from files + !write(*,*) 'initialized positions and length/width from file' + !write(*,*) '*************************************************************' + end if + +end subroutine iceberg_restart_with_icesheet + + +!**************************************************************************************************************************** +!**************************************************************************************************************************** + + +subroutine iceberg_out(partit) +! use iceberg_params + use g_clock !for dayold + implicit none + integer :: icbID, icbID_ISM, ib, istep +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_part_ass.h" + + icbID = 42 + icbID_ISM = 43 + + !calving_day has to be adjusted for restarts because calving_day gives the amount + !of days (since the model FIRST has been started) after which icebergs are released + !Criterion for calving is: + !if( real(istep) > real(step_per_day)*calving_day(ib) -1 ) then !iceberg calved + +! kh 10.02.21 istep is not initialized +!calving_day = calving_day - REAL(istep/step_per_day) + where(calving_day <= 0.0) + calving_day = 0.0 !to avoid negative calving_days + end where + + if(mype==0) then + open(unit=icbID,file=IcebergRestartPath,position='append', status='replace', form='formatted') + open(unit=icbID_ISM,file=IcebergRestartPath_ISM,position='append', status='replace', form='formatted') + + do ib=1, ib_num + + !write all parameters that icb_step needs: + write(icbID,'(18e15.7,I8,L,3e15.7,L,I5,L)') & + height_ib(ib),length_ib(ib),width_ib(ib), lon_deg(ib),lat_deg(ib), & + Co(ib),Ca(ib),Ci(ib), Cdo_skin(ib),Cda_skin(ib), rho_icb(ib), & + conc_sill(ib),P_sill(ib), rho_h2o(ib),rho_air(ib),rho_ice(ib), & + u_ib(ib),v_ib(ib), iceberg_elem(ib), find_iceberg_elem(ib), & + f_u_ib_old(ib), f_v_ib_old(ib), calving_day(ib), grounded(ib), scaling(ib), melted(ib) + + !*************************************************************** + !write new restart file with only non melted icebergs + if(.not.melted(ib)) then + !write all parameters that icb_step needs: + write(icbID_ISM,'(18e15.7,I8,L,3e15.7,L,I5,L)') & + height_ib(ib),length_ib(ib),width_ib(ib), lon_deg(ib),lat_deg(ib), & + Co(ib),Ca(ib),Ci(ib), Cdo_skin(ib),Cda_skin(ib), rho_icb(ib), & + conc_sill(ib),P_sill(ib), rho_h2o(ib),rho_air(ib),rho_ice(ib), & + u_ib(ib),v_ib(ib), iceberg_elem(ib), find_iceberg_elem(ib), & + f_u_ib_old(ib), f_v_ib_old(ib), calving_day(ib), grounded(ib), scaling(ib), melted(ib) + end if + + end do + close(icbID_ISM) + close(icbID) + end if +end subroutine iceberg_out + +!======================================================================== +! reads lon and lat values for buoys start position +! from files +! written by Madlen Kimmritz, 25.07.2015 +!======================================================================== +subroutine init_buoys +! use iceberg_params + use g_config + + implicit none + integer :: i + integer :: io_error + +!buoys_xlon_file > lon_deg + open(unit=97, file=buoys_xlon_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file buoys_xlon_file' + do i = 1, ib_num + read(97,*) lon_deg(i) + end do + close (97) +!buoys_ylat_file > lat_deg + open(unit=98, file=buoys_ylat_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file buoys_ylat_file' + do i = 1, ib_num + read(98,*) lat_deg(i) + end do + close(98) +end subroutine init_buoys +! +!-------------------------------------------------------------------------------------------- +! + +!======================================================================== +! reads lon and lat values for iceberg starting positions +! from files as well as their length and width +! written by Madlen Kimmritz, 25.07.2015 +! added length for iceberg case, 07.10.2015 +!======================================================================== +subroutine init_icebergs +! use iceberg_params + use g_config +! use MOD_PARTIT + + implicit none + integer :: i, myunit + integer :: io_error, io_read +!type(t_partit), intent(inout), target :: partit +!#include "associate_part_def.h" +!#include "associate_part_ass.h" + +!buoys_xlon_file > lon_deg + open(newunit=myunit, file=buoys_xlon_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file buoys_xlon_file' + do i = 1, ib_num + read(myunit,*,iostat=io_read) lon_deg(i) + end do + close (myunit) +!buoys_ylat_file > lat_deg + open(unit=98, file=buoys_ylat_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file buoys_ylat_file' + do i = 1, ib_num + read(98,*) lat_deg(i) + end do + close(98) +!length_icb_file > length_ib + open(unit=97, file=length_icb_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file length_icb_file' + do i = 1, ib_num + read(97,*) length_ib(i) + end do + close (97) +!width_icb_file > lat_deg + open(unit=98, file=width_icb_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file width_icb_file' + do i = 1, ib_num + read(98,*) width_ib(i) + end do + close(98) +!height_icb_file > height_ib + open(unit=97, file=height_icb_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file width_icb_file' + do i = 1, ib_num + read(97,*) height_ib(i) + end do + close(97) +!scaling_file + open(unit=98, file=scaling_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file scaling_file' + do i = 1, ib_num + read(98,*) scaling(i) + end do + close(98) + +end subroutine init_icebergs +! +!-------------------------------------------------------------------------------------------- +! + +subroutine init_icebergs_with_icesheet +! use iceberg_params + use g_config +! use MOD_PARTIT + + implicit none + integer :: i + integer :: io_error +!type(t_partit), intent(inout), target :: partit +!#include "associate_part_def.h" +!#include "associate_part_ass.h" + +!buoys_xlon_file > lon_deg + open(unit=97, file=buoys_xlon_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file buoys_xlon_file' + do i = 1+num_non_melted_icb, ib_num + read(97,*) lon_deg(i) + end do + close (97) +!buoys_ylat_file > lat_deg + open(unit=98, file=buoys_ylat_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file buoys_ylat_file' + do i = 1+num_non_melted_icb, ib_num + read(98,*) lat_deg(i) + end do + close(98) +!length_icb_file > length_ib + open(unit=97, file=length_icb_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file length_icb_file' + do i = 1+num_non_melted_icb, ib_num + read(97,*) length_ib(i) + end do + close (97) +!width_icb_file > lat_deg + open(unit=98, file=width_icb_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file width_icb_file' + do i = 1+num_non_melted_icb, ib_num + read(98,*) width_ib(i) + end do + close(98) +!height_icb_file > height_ib + open(unit=97, file=height_icb_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file width_icb_file' + do i = 1+num_non_melted_icb, ib_num + read(97,*) height_ib(i) + end do + close(97) +!scaling_file + open(unit=98, file=scaling_file,status='old',action='read',iostat=io_error) + if ( io_error.ne.0) stop 'ERROR while reading file scaling_file' + do i = 1+num_non_melted_icb, ib_num + read(98,*) scaling(i) + end do + close(98) + +end subroutine init_icebergs_with_icesheet +! +!-------------------------------------------------------------------------------------------- +! + +subroutine determine_save_count(partit) + ! computes save_count_buoys and prev_sec_in_year from records in existing netcdf file + !----------------------------------------------------------- + use g_clock +! use iceberg_params, only : file_icb_netcdf, save_count_buoys, prev_sec_in_year + !use iceberg_params, only : save_count_buoys, prev_sec_in_year + implicit none + +#include "netcdf.inc" + integer :: buoy_nrec + integer :: status, ncid + integer :: dimid_rec + integer :: time_varid +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_part_ass.h" + + if (mype==0) then + + ! open file + status = nf_open(file_icb_netcdf, nf_nowrite, ncid) + if (status .ne. nf_noerr) call handle_err(status) + + ! inquire time dimension ID and its length + status = nf_inq_dimid(ncid, 'time', dimid_rec) + if(status .ne. nf_noerr) call handle_err(status) + status = nf_inq_dimlen(ncid, dimid_rec, buoy_nrec) + if(status .ne. nf_noerr) call handle_err(status) + + ! the next buoy/iceberg record to be saved + save_count_buoys=buoy_nrec+1 + + write(*,*) 'next record is #',save_count_buoys + + ! load sec_in_year up to now in 'prev_sec_in_year', time axis will be continued + status=nf_inq_varid(ncid, 'time', time_varid) + if (status .ne. nf_noerr) call handle_err(status) + status=nf_get_vara_double(ncid, time_varid, save_count_buoys-1, 1, prev_sec_in_year) + if (status .ne. nf_noerr) call handle_err(status) + + write(*,*) 'seconds passed up to now: ',prev_sec_in_year + + !close file + status=nf_close(ncid) + if (status .ne. nf_noerr) call handle_err(status) + +end if + +end subroutine determine_save_count +!============================================================================================= + +! +!-------------------------------------------------------------------------------------------- +! +subroutine init_buoy_output(partit) + ! Initialize output file for buoys/icebergs + ! written by Madlen Kimmritz, 24.07.2015 + ! reviewed by T. Rackow, 14.08.2015 + !----------------------------------------------------------- + use g_clock + use g_config, only : ib_num +! use iceberg_params, only : file_icb_netcdf, save_count_buoys !ggf in namelist + implicit none + +#include "netcdf.inc" + integer :: status,ncid,year_start,month_start,day_start + integer :: dimid_ib, dimid_rec, dimids(2) + integer :: time_varid, iter_varid + integer :: lonrad_id, latrad_id, londeg_id, latdeg_id + integer :: frozen_id, dudt_id, dvdt_id + integer :: uib_id, vib_id + integer :: height_id, length_id, width_id + integer :: bvl_id, lvlv_id, lvle_id, lvlb_id, felem_id + character(100) :: longname, att_text, description +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_part_ass.h" + + if (mype==0) then + write(*,*) 'initialize new buoy/iceberg output file' + + + ! create a file + status = nf_create(file_icb_netcdf, nf_clobber, ncid) + if (status.ne.nf_noerr) call handle_err(status) + + ! Define the dimensions + status = nf_def_dim(ncid, 'number_tracer', ib_num, dimid_ib) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_def_dim(ncid, 'time', NF_UNLIMITED, dimid_rec) + if (status .ne. nf_noerr) call handle_err(status) + + + ! Define the time and iteration variables + status = nf_def_var(ncid, 'time', NF_DOUBLE, 1, dimid_rec, time_varid) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_def_var(ncid, 'iter', NF_INT, 1, dimid_rec, iter_varid) + if (status .ne. nf_noerr) call handle_err(status) + + ! Define the netCDF variables for the tracers. + ! In Fortran, the unlimited dimension must come + ! last on the list of dimids. + dimids(1) = dimid_ib + dimids(2) = dimid_rec + + + status = nf_def_var(ncid, 'pos_lon_rad', NF_DOUBLE, 2, dimids, lonrad_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'pos_lat_rad', NF_DOUBLE, 2, dimids, latrad_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'pos_lon_deg', NF_DOUBLE, 2, dimids, londeg_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'pos_lat_deg', NF_DOUBLE, 2, dimids, latdeg_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'frozen_in', NF_DOUBLE, 2, dimids, frozen_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'du_dt', NF_DOUBLE, 2, dimids, dudt_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'dv_dt', NF_DOUBLE, 2, dimids, dvdt_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'icb_vel_u', NF_DOUBLE, 2, dimids, uib_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'icb_vel_v', NF_DOUBLE, 2, dimids, vib_id) + if (status .ne. nf_noerr) call handle_err(status) + + ! 3 dimensions of the iceberg, comment for buoy case + + status = nf_def_var(ncid, 'height', NF_DOUBLE, 2, dimids, height_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'length', NF_DOUBLE, 2, dimids, length_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'width', NF_DOUBLE, 2, dimids, width_id) + if (status .ne. nf_noerr) call handle_err(status) + + ! 4 additional iceberg variables (meltrates), comment for buoy case + + status = nf_def_var(ncid, 'bvl', NF_DOUBLE, 2, dimids, bvl_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'lvlv', NF_DOUBLE, 2, dimids, lvlv_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'lvle', NF_DOUBLE, 2, dimids, lvle_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_def_var(ncid, 'lvlb', NF_DOUBLE, 2, dimids, lvlb_id) + if (status .ne. nf_noerr) call handle_err(status) + + ! LA: add felem + status = nf_def_var(ncid, 'felem', NF_DOUBLE, 2, dimids, felem_id) + if (status .ne. nf_noerr) call handle_err(status) + + ! Assign long_name and units attributes to variables. + longname='time' ! use NetCDF Climate and Forecast (CF) Metadata Convention + status = nf_PUT_ATT_TEXT(ncid, time_varid, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + write(att_text, '(a14,I4.4,a1,I2.2,a1,I2.2,a6)'), 'seconds since ', year_start, '-', month_start, '-', day_start, ' 00:00:00' + status = nf_PUT_ATT_TEXT(ncid, time_varid, 'units', len_trim(att_text), trim(att_text)) + if (status .ne. nf_noerr) call handle_err(status) + if (include_fleapyear) then + att_text='standard' + else + att_text='noleap' + end if + status = nf_put_att_text(ncid, time_varid, 'calendar', len_trim(att_text), trim(att_text)) + if (status .ne. nf_noerr) call handle_err(status) + longname='iteration_count' + status = nf_PUT_ATT_TEXT(ncid, iter_varid, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + + longname='longitude of buoy/iceberg position in radiant' + status = nf_PUT_ATT_TEXT(ncid, lonrad_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, lonrad_id, 'units', 7, 'radiant') + if (status .ne. nf_noerr) call handle_err(status) + !rotated or not rotated due to setting in iceberg module + description='(un)rotated according to setting of l_geo_out in iceberg module' + status = nf_put_att_text(ncid, lonrad_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + + longname='latitude of buoy/iceberg position in radiant' + status = nf_PUT_ATT_TEXT(ncid, latrad_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, latrad_id, 'units', 7, 'radiant') + if (status .ne. nf_noerr) call handle_err(status) + !rotated or not rotated due to setting in iceberg module + description='(un)rotated according to setting of l_geo_out in iceberg module' + status = nf_put_att_text(ncid, latrad_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + + longname='longitude of buoy/iceberg position in degree' + status = nf_PUT_ATT_TEXT(ncid, londeg_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, londeg_id, 'units', 12, 'degrees_east') + if (status .ne. nf_noerr) call handle_err(status) + !rotated or not rotated due to setting in iceberg module + description='(un)rotated according to setting of l_geo_out in iceberg module' + status = nf_put_att_text(ncid, londeg_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + + longname='latitude of buoy/iceberg position in degree' + status = nf_PUT_ATT_TEXT(ncid, latdeg_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, latdeg_id, 'units', 13, 'degrees_north') + if (status .ne. nf_noerr) call handle_err(status) + !rotated or not rotated due to setting in iceberg module + description='(un)rotated according to setting of l_geo_out in iceberg module' + status = nf_put_att_text(ncid, latdeg_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + + longname='status of buoy/iceberg (frozen in/not frozen in)' + status = nf_PUT_ATT_TEXT(ncid, frozen_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + description='1 = frozen, 0 = not frozen, else partially frozen' + status = nf_put_att_text(ncid, frozen_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, frozen_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + longname='du/dt of buoy/iceberg in last time step' + status = nf_PUT_ATT_TEXT(ncid, dudt_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, dudt_id, 'units', 8, 'm s^(-2)') + if (status .ne. nf_noerr) call handle_err(status) + !rotated or not rotated due to setting in iceberg module + description='(un)rotated according to setting of l_geo_out in iceberg module' + status = nf_put_att_text(ncid, dudt_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, dudt_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + longname='dv/dt of buoy/iceberg in last time step' + status = nf_PUT_ATT_TEXT(ncid, dvdt_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, dvdt_id, 'units', 8, 'm s^(-2)') + if (status .ne. nf_noerr) call handle_err(status) + !rotated or not rotated due to setting in iceberg module + description='(un)rotated according to setting of l_geo_out in iceberg module' + status = nf_put_att_text(ncid, dvdt_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, dvdt_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + longname='velocity of buoy/iceberg, u component' + status = nf_PUT_ATT_TEXT(ncid, uib_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, uib_id, 'units', 8, 'm s^(-1)') + if (status .ne. nf_noerr) call handle_err(status) + !rotated or not rotated due to setting in iceberg module + description='(un)rotated according to setting of l_geo_out in iceberg module' + status = nf_put_att_text(ncid, uib_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, uib_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + longname='velocity of buoy/iceberg, v component' + status = nf_PUT_ATT_TEXT(ncid, vib_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, vib_id, 'units', 8, 'm s^(-1)') + if (status .ne. nf_noerr) call handle_err(status) + !rotated or not rotated due to setting in iceberg module + description='(un)rotated according to setting of l_geo_out in iceberg module' + status = nf_put_att_text(ncid, vib_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, vib_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + ! 3 dimensions of the iceberg, comment for buoy case + + longname='height of the iceberg' + status = nf_PUT_ATT_TEXT(ncid, height_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, height_id, 'units', 1, 'm') + if (status .ne. nf_noerr) call handle_err(status) + description='freeboard + draft' + status = nf_put_att_text(ncid, height_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, height_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + longname='length of the iceberg' + status = nf_PUT_ATT_TEXT(ncid, length_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, length_id, 'units', 1, 'm') + if (status .ne. nf_noerr) call handle_err(status) + description='open' + status = nf_put_att_text(ncid, length_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, length_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + longname='width of the iceberg' + status = nf_PUT_ATT_TEXT(ncid, width_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, width_id, 'units', 1, 'm') + if (status .ne. nf_noerr) call handle_err(status) + description='open' + status = nf_put_att_text(ncid, width_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, width_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + + ! 4 additional iceberg variables (meltrates), comment for buoy case + + longname='basal volume loss' + status = nf_PUT_ATT_TEXT(ncid, bvl_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, bvl_id, 'units', 18, 'm^3 (ice) day^(-1)') + if (status .ne. nf_noerr) call handle_err(status) + description='losses are averaged over the preceding output interval' + status = nf_put_att_text(ncid, bvl_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, bvl_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + longname='lateral volume loss due to 1) bouyant convection' + status = nf_PUT_ATT_TEXT(ncid, lvlv_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, lvlv_id, 'units', 18, 'm^3 (ice) day^(-1)') + if (status .ne. nf_noerr) call handle_err(status) + description='losses are averaged over the preceding output interval' + status = nf_put_att_text(ncid, lvlv_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, lvlv_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + longname='lateral volume loss due to 2) wave erosion' + status = nf_PUT_ATT_TEXT(ncid, lvle_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, lvle_id, 'units', 18, 'm^3 (ice) day^(-1)') + if (status .ne. nf_noerr) call handle_err(status) + description='losses are averaged over the preceding output interval' + status = nf_put_att_text(ncid, lvle_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, lvle_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + longname='lateral volume loss due to 3) "basal" formulation' + status = nf_PUT_ATT_TEXT(ncid, lvlb_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, lvlb_id, 'units', 18, 'm^3 (ice) day^(-1)') + if (status .ne. nf_noerr) call handle_err(status) + description='losses are averaged over the preceding output interval' + status = nf_put_att_text(ncid, lvlb_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, lvlb_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + ! LA: add felem + longname='fesom element' + status = nf_PUT_ATT_TEXT(ncid, felem_id, 'long_name', len_trim(longname), trim(longname)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_put_att_text(ncid, felem_id, 'units', 18, '') + if (status .ne. nf_noerr) call handle_err(status) + description='' + status = nf_put_att_text(ncid, felem_id, 'description', len_trim(description), trim(description)) + if (status .ne. nf_noerr) call handle_err(status) + status = nf_PUT_ATT_TEXT(ncid, felem_id, 'Coordinates', 23, 'pos_lon_deg pos_lat_deg') ! arcGIS + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_enddef(ncid) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_close(ncid) + if (status .ne. nf_noerr) call handle_err(status) + + ! initialize the counter for saving results + save_count_buoys=1 + write(*,*) 'initialize new buoy/iceberg output file: done' + + end if +end subroutine init_buoy_output +!============================================================================================= + +!============================================================================================= + +subroutine write_buoy_props_netcdf(partit) + ! write output file for buoys/icebergs for current time step + ! written by Madlen Kimmritz, 25.07.2015 + ! reviewed by T. Rackow, 17.08.2015 + !----------------------------------------------------------- + + use g_config + use g_clock +! use iceberg_params, only : buoy_props, file_icb_netcdf, save_count_buoys, prev_sec_in_year, bvl_mean, lvlv_mean, lvle_mean, lvlb_mean + use g_forcing_param + + implicit none + +#include "netcdf.inc" + + integer :: status,ncid, istep + integer :: dimid_ib, dimid_rec, dimids(2) + integer :: time_varid, iter_varid + integer :: lonrad_id, latrad_id, londeg_id, latdeg_id + integer :: frozen_id, dudt_id, dvdt_id + integer :: uib_id, vib_id + integer :: height_id, length_id, width_id + integer :: bvl_id, lvlv_id, lvle_id, lvlb_id, felem_id + integer :: start(2), count(2) + real(kind=8) :: sec_in_year +type(t_partit), intent(inout), target :: partit +!type(t_ice), intent(inout), target :: ice +#include "associate_part_def.h" +#include "associate_part_ass.h" + +! /gfs1/work/hbkkim15/output/slabt/buoys_track.nc + + if (mype==0) then + +! kh 16.03.21 ?! istep is not initialized, intitialize to 0 here + istep = 0 + sec_in_year=dt*istep + + ! open files + status = nf_open(trim(file_icb_netcdf), nf_write, ncid) + if (status .ne. nf_noerr) call handle_err(status) + + ! inquire variable id + + status = nf_inq_varid(ncid, 'time', time_varid) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_inq_varid(ncid, 'iter', iter_varid) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'pos_lon_rad', lonrad_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'pos_lat_rad', latrad_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'pos_lon_deg', londeg_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'pos_lat_deg', latdeg_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'frozen_in', frozen_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'du_dt', dudt_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'dv_dt', dvdt_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'icb_vel_u', uib_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'icb_vel_v', vib_id) + if (status .ne. nf_noerr) call handle_err(status) + + ! inquire 3 additional IDs for iceberg case, comment for buoy case + + status = nf_inq_varid(ncid, 'height', height_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'length', length_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'width', width_id) + if (status .ne. nf_noerr) call handle_err(status) + + ! inquire 4 additional IDs for iceberg case, comment for buoy case + + status = nf_inq_varid(ncid, 'bvl', bvl_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'lvlv', lvlv_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'lvle', lvle_id) + if (status .ne. nf_noerr) call handle_err(status) + + status = nf_inq_varid(ncid, 'lvlb', lvlb_id) + if (status .ne. nf_noerr) call handle_err(status) + + ! * LA: include fesom elemt in output + status = nf_inq_varid(ncid, 'felem', felem_id) + if (status .ne. nf_noerr) call handle_err(status) + + !buoy_props(ib, 1) = lon_rad_out + !buoy_props(ib, 2) = lat_rad_out + !buoy_props(ib, 3) = lon_deg_out + !buoy_props(ib, 4) = lat_deg_out + !buoy_props(ib, 5) = frozen_in + !buoy_props(ib, 6) = dudt_out + !buoy_props(ib, 7) = dvdt_out + !buoy_props(ib, 8) = u_ib_out + !buoy_props(ib, 9) = v_ib_out + !buoy_props(ib,10) = height_ib + !buoy_props(ib,11) = length_ib + !buoy_props(ib,12) = width_ib + + !bvl_mean(ib)*step_per_day + !lvlv_mean(ib)*step_per_day + !lvle_mean(ib)*step_per_day + !lvlb_mean(ib)*step_per_day + + ! time and iteration + status=nf_put_vara_double(ncid, time_varid, save_count_buoys, 1, prev_sec_in_year+sec_in_year) + if (status .ne. nf_noerr) call handle_err(status) + status=nf_put_vara_int(ncid, iter_varid, save_count_buoys, 1, istep) + if (status .ne. nf_noerr) call handle_err(status) + + !variables + start=(/1,save_count_buoys/) + count=(/ib_num, 1/) + status=nf_put_vara_double(ncid, lonrad_id, start, count, buoy_props(:, 1)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, latrad_id, start, count, buoy_props(:, 2)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, londeg_id, start, count, buoy_props(:, 3)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, latdeg_id, start, count, buoy_props(:, 4)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, frozen_id, start, count, buoy_props(:, 5)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, dudt_id, start, count, buoy_props(:, 6)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, dvdt_id, start, count, buoy_props(:, 7)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, uib_id, start, count, buoy_props(:, 8)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, vib_id, start, count, buoy_props(:, 9)) + if (status .ne. nf_noerr) call handle_err(status) + + ! write 3 additional variables for iceberg case, comment for buoy case + + status=nf_put_vara_double(ncid, height_id, start, count, buoy_props(:,10)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, length_id, start, count, buoy_props(:,11)) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, width_id, start, count, buoy_props(:,12)) + if (status .ne. nf_noerr) call handle_err(status) + + ! write 4 additional variables for iceberg case, comment for buoy case + + status=nf_put_vara_double(ncid, bvl_id, start, count, bvl_mean(:)*step_per_day) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, lvlv_id, start, count, lvlv_mean(:)*step_per_day) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, lvle_id, start, count, lvle_mean(:)*step_per_day) + if (status .ne. nf_noerr) call handle_err(status) + + status=nf_put_vara_double(ncid, lvlb_id, start, count, lvlb_mean(:)*step_per_day) + if (status .ne. nf_noerr) call handle_err(status) + + ! LA: add felem + status=nf_put_vara_double(ncid, felem_id, start, count, buoy_props(:,13)) + if (status .ne. nf_noerr) call handle_err(status) + + !close file + status=nf_close(ncid) + if (status .ne. nf_noerr) call handle_err(status) + + save_count_buoys=save_count_buoys+1 +!========================================================== + + end if!mype==0 + + +end subroutine write_buoy_props_netcdf +end module iceberg_step diff --git a/src/icb_thermo.F90 b/src/icb_thermo.F90 new file mode 100644 index 000000000..624f2a758 --- /dev/null +++ b/src/icb_thermo.F90 @@ -0,0 +1,635 @@ +!============================================================================== +! calculates the empirical melt rates of the iceberg as in +! Martin: 'Parameterizing the fresh-water flux from land ice to ocean +! with interactive icebergs in a coupled climate model'(2010) +! and Hellmer et al. (1997). +! +! (notice that the melt rates are in terms of m/s though, not in m/day) +! +! bottom melt rate : M_b [m/s] +! lateral melt rate : M_v [m/s] +! wave erosion : M_e [m/s] +! lateral (basal) melt rate : M_bv [m/s] +! +! Thomas Rackow, 29.06.2010 +! - modified 11.06.2014 ( 3eq formulation for basal melting; +! use 3D information for T,S and velocities +! instead of SSTs; M_v depends on 'thermal driving') +!============================================================================== +subroutine iceberg_meltrates( M_b, M_v, M_e, M_bv, & + u_ib,v_ib, uo_ib,vo_ib, ua_ib,va_ib, & + sst_ib, length_ib, conci_ib, & + uo_keel_ib, vo_keel_ib, T_keel_ib, S_keel_ib, depth_ib, & + T_ave_ib, S_ave_ib, ib) + + use o_param + use g_clock + use g_forcing_arrays + use g_rotate_grid + + use iceberg_params, only: fwe_flux_ib, fwl_flux_ib, fwb_flux_ib, fwbv_flux_ib, heat_flux_ib + + implicit none + + real, intent(IN) :: u_ib,v_ib, uo_ib,vo_ib, ua_ib,va_ib !iceberg velo, (int.) ocean & atm velo + real, intent(IN) :: uo_keel_ib, vo_keel_ib !ocean velo at iceberg's draft + real, intent(IN) :: sst_ib, length_ib, conci_ib !SST, length and sea ice conc. + real, intent(IN) :: T_keel_ib, S_keel_ib, depth_ib !T & S at depth 'depth_ib' + real, intent(IN) :: T_ave_ib, S_ave_ib !T & S averaged, i.e. at 'depth_ib/2' + integer, intent(IN) :: ib !iceberg ID + real, intent(OUT) :: M_b, M_v, M_e, M_bv !melt rates [m (ice) per s] + + + real :: absamino, damping, sea_state, v_ibmino + real :: tf, T_d !freezing temp. and 'thermal driving' + + !3-eq. formulation for bottom melting [m/s] + v_ibmino = sqrt( (u_ib - uo_keel_ib)**2 + (v_ib - vo_keel_ib)**2 ) + call iceberg_heat_water_fluxes_3eq(ib, M_b, T_keel_ib,S_keel_ib,v_ibmino, depth_ib, tf) + + !3-eq. formulation for lateral 'basal' melting [m/s] + v_ibmino = sqrt( (u_ib - uo_ib)**2 + (v_ib - vo_ib)**2 ) ! depth-average rel. velocity + call iceberg_heat_water_fluxes_3eq(ib, M_bv, T_ave_ib,S_ave_ib,v_ibmino, depth_ib/2.0, tf) + + !'thermal driving', defined as the elevation of ambient water + !temperature above freezing point' (Neshyba and Josberger, 1979). + T_d = T_ave_ib - tf + if(T_d < 0.) T_d = 0. + !write(*,*) 'thermal driving:',T_d,'; Tf:',tf,'T_ave:',T_ave_ib + + !lateral melt (buoyant convection) + !M_v is a function of the 'thermal driving', NOT just sst! Cf. Neshyba and Josberger (1979) + M_v = 0.00762 * T_d + 0.00129 * T_d**2 + M_v = M_v/86400. + + !wave erosion + absamino = sqrt( (ua_ib - uo_ib)**2 + (va_ib - vo_ib)**2 ) + sea_state = 3./2.*sqrt(absamino) + 1./10.*absamino + damping = 0.5 * (1.0 + cos(conci_ib**3 * Pi)) + M_e = 1./6. * sea_state * (sst_ib + 2.0) * damping + M_e = M_e/86400. + !fwe_flux_ib = M_e +end subroutine iceberg_meltrates + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +!============================================================================== +! calculates the new iceberg dimensions resulting from melting rates and +! computes the mass (volume) losses +! +! Thomas Rackow, 29.06.2010 +! - modified 07.06.2014 (changed lateral 'basal' melting, output of averaged volume losses) +!============================================================================== +subroutine iceberg_newdimensions(partit, ib, depth_ib,height_ib,length_ib,width_ib,M_b,M_v,M_e,M_bv, & + rho_h2o, rho_icb, file_meltrates) + + use o_param !for step_per_day + use MOD_PARTIT !for mype + use g_clock + use g_forcing_arrays + use g_rotate_grid + use iceberg_params, only: l_weeksmellor, ascii_out, icb_outfreq, vl_block, bvl_mean, lvlv_mean, lvle_mean, lvlb_mean, smallestvol_icb, fwb_flux_ib, fwe_flux_ib, fwbv_flux_ib, fwl_flux_ib, scaling, heat_flux_ib, lheat_flux_ib + use g_config, only: steps_per_ib_step + + implicit none + + integer, intent(IN) :: ib + real, intent(INOUT) :: depth_ib, height_ib, length_ib, width_ib + real, intent(IN) :: M_b, M_v, M_e, M_bv, rho_h2o, rho_icb + character, intent(IN) :: file_meltrates*80 + + real :: dh_b, dh_v, dh_e, dh_bv, bvl, lvl_b, lvl_v, lvl_e, tvl, volume_before, volume_after + integer :: icbID + logical :: force_last_output + real, dimension(4) :: arr + integer :: istep + ! LA: include latent heat 2023-04-04 + real(kind=8),parameter :: L = 334000. ! [J/Kg] + +type(t_partit), intent(inout), target :: partit +#include "associate_part_def.h" +#include "associate_part_ass.h" + + !in case the iceberg melts in this step, output has to be written (set to true below) + force_last_output=.false. + + !changes in this timestep: + dh_b = M_b*dt*REAL(steps_per_ib_step) !*scaling(ib) !change of height.. + dh_v = M_v*dt*REAL(steps_per_ib_step) !*scaling(ib) !..and length due to melting.. + dh_e = M_e*dt*REAL(steps_per_ib_step) !*scaling(ib) !..and due to wave erosion [m]. + dh_bv = M_bv*dt*REAL(steps_per_ib_step) !*scaling(ib) !change of length due to 'basal meltrate' + + !CALCULATION OF WORKING SURFACES AS IN BIGG (1997) & SILVA (2010) + !basal volume loss + bvl = dh_b*length_ib**2 + !lateral volume loss + !lvl1 = (dh_b+dh_v) *2*length_ib*abs(depth_ib)+ dh_e*length_ib*height_ib + !lvl2 = (dh_b+dh_v) *2*width_ib*abs(depth_ib) + dh_e*width_ib *height_ib + lvl_e = dh_e*length_ib*height_ib + dh_e*width_ib*height_ib ! erosion just at 2 sides + + lvl_b = dh_bv*2*length_ib*abs(depth_ib) + dh_bv*2*width_ib*abs(depth_ib) ! at all 4 sides + + lvl_v = dh_v*2*length_ib*abs(depth_ib) + dh_v*2*width_ib*abs(depth_ib) ! at all 4 sides + !total volume loss + tvl = bvl + lvl_b + lvl_v + lvl_e ![m^3] per timestep, for freshwater flux convert somehow to [m/s] + ! by distributing over area(iceberg_elem) or over patch + ! surrounding one node + volume_before=height_ib*length_ib*width_ib + + if((tvl .ge. volume_before) .OR. (volume_before .le. smallestvol_icb)) then + volume_after=0.0 + depth_ib = 0.0 + height_ib= 0.0 + length_ib= 0.0 + width_ib = 0.0 + tvl = volume_before + ! define last tvl to be erosional loss + bvl = 0.0 + lvl_b = 0.0 + lvl_v = 0.0 + lvl_e = tvl + force_last_output = .true. + else + volume_after=volume_before-tvl + + !calculating the new iceberg dimensions + height_ib= height_ib - dh_b + depth_ib = -height_ib * rho_icb/rho_h2o + + !calculate length_ib so that new volume is correct + length_ib= sqrt(volume_after/height_ib) + width_ib = length_ib + + !distribute dh_e equally between length and width + !as in code of michael schodlok, but not dh_v? + + volume_after=height_ib*length_ib*width_ib + + !iceberg smaller than critical value after melting? + if (volume_after .le. smallestvol_icb) then + volume_after=0.0 + depth_ib = 0.0 + height_ib= 0.0 + length_ib= 0.0 + width_ib = 0.0 + tvl = volume_before + ! define last tvl to be erosional loss + bvl = 0.0 + lvl_b = 0.0 + lvl_v = 0.0 + lvl_e = tvl + force_last_output = .true. + end if + end if + fwb_flux_ib(ib) = -bvl*rho_icb/rho_h2o/dt/REAL(steps_per_ib_step)*scaling(ib) + fwe_flux_ib(ib) = -lvl_e*rho_icb/rho_h2o/dt/REAL(steps_per_ib_step)*scaling(ib) + fwbv_flux_ib(ib) = -lvl_b*rho_icb/rho_h2o/dt/REAL(steps_per_ib_step)*scaling(ib) + fwl_flux_ib(ib) = -lvl_v*rho_icb/rho_h2o/dt/REAL(steps_per_ib_step)*scaling(ib) + + !stability criterion: icebergs are allowed to roll over + if(l_weeksmellor) then + call weeksmellor( depth_ib, height_ib, length_ib, width_ib, & + rho_h2o, rho_icb, volume_after) + end if + + + !OUTPUT of averaged meltrates in [m^3 (ice) per day] + bvl_mean(ib)=bvl_mean(ib)+(bvl/real(icb_outfreq)*REAL(steps_per_ib_step)*scaling(ib)) + lvlv_mean(ib)=lvlv_mean(ib)+(lvl_v/real(icb_outfreq)*REAL(steps_per_ib_step)*scaling(ib)) + lvle_mean(ib)=lvle_mean(ib)+(lvl_e/real(icb_outfreq)*REAL(steps_per_ib_step)*scaling(ib)) + lvlb_mean(ib)=lvlb_mean(ib)+(lvl_b/real(icb_outfreq)*REAL(steps_per_ib_step)*scaling(ib)) + + !if( (mod(istep,icb_outfreq)==0 .OR. force_last_output) .AND. ascii_out) then + ! icbID = mype+10 + ! open(unit=icbID,file=file_meltrates,position='append') + ! !old: write(icbID,'(6e15.7)') M_b, M_v, M_e, height_ib, length_ib, tvl*step_per_day*steps_per_FESOM_step + ! tvl=bvl_mean(ib) + lvlv_mean(ib) + lvle_mean(ib) + lvlb_mean(ib) + ! !new output structure with rev. 20: + ! write(icbID,'(7e15.7)') bvl_mean(ib)*step_per_day, lvlv_mean(ib)*step_per_day, lvle_mean(ib)*step_per_day, & + ! lvlb_mean(ib)*step_per_day, height_ib, length_ib, tvl*step_per_day + ! close(icbID) + ! ! set back to zero for the next round + ! bvl_mean(ib)=0.0 + ! lvlv_mean(ib)=0.0 + ! lvle_mean(ib)=0.0 + ! lvlb_mean(ib)=0.0 + !end if + + !values for communication + arr= [ bvl_mean(ib), lvlv_mean(ib), lvle_mean(ib), lvlb_mean(ib) ] + + !save in larger array + vl_block((ib-1)*4+1 : ib*4)=arr + + ! ----------------------- + ! LA: set iceberg heatflux at least to latent heat 2023-04-04 + ! Latent heat flux at base and sides also changes lines 475/476 + lheat_flux_ib(ib) = rho_icb*L*tvl*scaling(ib)/dt/REAL(steps_per_ib_step) + if( (heat_flux_ib(ib).gt.0.0) .and. (heat_flux_ib(ib).lt.lheat_flux_ib(ib))) then + heat_flux_ib(ib)=lheat_flux_ib(ib) + end if + ! ----------------------- +end subroutine iceberg_newdimensions + + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +subroutine weeksmellor(depth_ib, height_ib, length_ib, width_ib, rho_h2o, rho_icb, volume_after) + implicit none + + real, intent(INOUT) :: depth_ib, height_ib, length_ib, width_ib + real, intent(IN) :: rho_h2o, rho_icb, volume_after + + logical :: l_rollover + + !check stability + l_rollover = (length_ib < sqrt(0.92 * height_ib**2 + 58.32 * height_ib)) + + if(l_rollover) then + height_ib= length_ib + depth_ib = -height_ib * rho_icb/rho_h2o + + !calculate length_ib so that + !volume is still correct + length_ib= sqrt(volume_after/height_ib) + width_ib = length_ib + end if + +end subroutine weeksmellor + + !*************************************************************************************************************************** + !*************************************************************************************************************************** + +subroutine iceberg_heat_water_fluxes_3eq(ib, M_b, T_ib,S_ib,v_rel, depth_ib, t_freeze) + ! The three-equation model of ice-shelf ocean interaction (Hellmer et al., 1997) + ! Code derived from BRIOS subroutine iceshelf (which goes back to H.Hellmer's 2D ice shelf model code) + ! adjusted for use in FESOM by Ralph Timmermann, 16.02.2011 + ! adopted and modified for iceberg basal melting by Thomas Rackow, 11.06.2014 + !---------------------------------------------------------------- + + use iceberg_params + use g_config + + implicit none + + integer, INTENT(IN) :: ib + real(kind=8),INTENT(OUT) :: M_b, t_freeze + real(kind=8),INTENT(IN) :: T_ib, S_ib ! ocean temperature & salinity (at depth 'depth_ib') + real(kind=8),INTENT(IN) :: v_rel, depth_ib ! relative velocity iceberg-ocean (at depth 'depth_ib') + + real (kind=8) :: temp,sal,tin,zice + real (kind=8) :: rhow, rhor, rho + real (kind=8) :: gats1, gats2, gas, gat + real (kind=8) :: ep1,ep2,ep3,ep4,ep5,ep31 + real (kind=8) :: ex1,ex2,ex3,ex4,ex5,ex6 + real (kind=8) :: vt1,sr1,sr2,sf1,sf2,tf1,tf2,tf,sf,seta,re + integer :: n, n3, nk + + real(kind=8),parameter :: rp = 0. !reference pressure + real(kind=8),parameter :: a = -0.0575 !Foldvik&Kvinge (1974) + real(kind=8),parameter :: b = 0.0901 + real(kind=8),parameter :: c = 7.61e-4 + + real(kind=8),parameter :: pr = 13.8 !Prandtl number [dimensionless] + real(kind=8),parameter :: sc = 2432. !Schmidt number [dimensionless] + real(kind=8),parameter :: ak = 2.50e-3 !dimensionless drag coeff. + real(kind=8),parameter :: sak1= sqrt(ak) + real(kind=8),parameter :: un = 1.95e-6 !kinematic viscosity [m2/s] + real(kind=8),parameter :: pr1 = pr**(2./3.) !Jenkins (1991) + real(kind=8),parameter :: sc1 = sc**(2./3.) + + real(kind=8),parameter :: tob= -20. !temperatur at the ice surface + !real(kind=8),parameter :: rhoi= 920. !mean ice density + !real(kind=8),parameter :: rhoh2o= 1027.5 !water density + real(kind=8),parameter :: rhoi= 850.0 !mean ice(berg) density (see values in icb_modules.F90) + real(kind=8),parameter :: cpw = 4180.0 !Barnier et al. (1995) + real(kind=8),parameter :: lhf = 3.33e+5 !latent heat of fusion + real(kind=8),parameter :: tdif= 1.54e-6 !thermal conductivity of ice shelf !RG4190 / RG44027 + real(kind=8),parameter :: atk = 273.15 !0 deg C in Kelvin + real(kind=8),parameter :: cpi = 152.5+7.122*(atk+tob) !Paterson:"The Physics of Glaciers" + + real(kind=8),parameter :: L = 334000. ! [J/Kg] + + temp = T_ib + sal = S_ib + zice = depth_ib !(<0) + + ! Calculate the in-situ temperature tin + !call potit(s(i,j,N,lrhs)+35.0,t(i,j,N,lrhs),-zice(i,j),rp,tin) + call potit_ib(ib, sal,temp,abs(zice),rp,tin) + + ! Calculate or prescribe the turbulent heat and salt transfer coeff. GAT and GAS + ! velocity-dependent approach of Jenkins (1991) + + vt1 = v_rel ! relative velocity iceberg-ocean (at depth 'depth_ib') + vt1 = max(vt1,0.005) ! RG44030 + + re = 10./un !vt1*re (=velocity times length scale over kinematic viscosity) is the Reynolds number + + gats1= sak1*vt1 + gats2= 2.12*log(gats1*re)-9. + gat = gats1/(gats2+12.5*pr1) + gas = gats1/(gats2+12.5*sc1) + + !RG3417 gat = 1.00e-4 ![m/s] RT: to be replaced by velocity-dependent equations later + !RG3417 gas = 5.05e-7 ![m/s] RT: to be replaced by velocity-dependent equations later + + ! Calculate + ! density in the boundary layer: rhow + ! and interface pressure pg [dbar], + ! Solve a quadratic equation for the interface salinity sb + ! to determine the melting/freezing rate seta. + + call fcn_density(temp,sal,zice,rho) + rhow = rho !fcn_density returns full in-situ density now! + ! in previous FESOM version, which has density anomaly from fcn_density, so used density_0+rho + ! was rhow= rho0+rho(i,j,N) in BRIOS + + rhor= rhoi/rhow + + ep1 = cpw*gat + ep2 = cpi*gas + ep3 = lhf*gas + ep31 = -rhor*cpi*tdif/zice !RG4190 / RG44027 + ep4 = b+c*zice + ep5 = gas/rhor + + +!rt RG4190 ! negative heat flux term in the ice (due to -kappa/D) +!rt RG4190 ex1 = a*(ep1-ep2) +!rt RG4190 ex2 = ep1*(ep4-tin)+ep2*(tob+a*sal-ep4)-ep3 +!rt RG4190 ex3 = sal*(ep2*(ep4-tob)+ep3) + + +!RT RG4190/RG44027: +! In case of melting ice account for changing temperature gradient, i.e. switch from heat conduction to heat capacity approach +!TR What to do in iceberg case? LEAVE AS IT IS + tf = a*sal+ep4 + if(tin.lt.tf) then + !freezing + ex1 = a*(ep1+ep31) + ex2 = ep1*(tin-ep4)+ep3+ep31*(tob-ep4) ! heat conduction + ex3 = ep3*sal + ex6 = 0.5 + else + !melting + ex1 = a*(ep1-ep2) + ex2 = ep1*(ep4-tin)+ep2*(tob+a*sal-ep4)-ep3 ! heat capacity + ex3 = sal*(ep2*(ep4-tob)+ep3) + ex6 = -0.5 + endif +!RT RG4190- + + + ex4 = ex2/ex1 + ex5 = ex3/ex1 + + sr1 = 0.25*ex4*ex4-ex5 + sr2 = ex6*ex4 ! modified for RG4190 / RG44027 + sf1 = sr2+sqrt(sr1) + tf1 = a*sf1+ep4 + sf2 = sr2-sqrt(sr1) + tf2 = a*sf2+ep4 + + ! Salinities < 0 psu are not defined, therefore pick the positive of the two solutions: + if(sf1.gt.0.) then + tf = tf1 + sf = sf1 + else + tf = tf2 + sf = sf2 + endif + + t_freeze = tf ! output of freezing temperature + + ! Calculate the melting/freezing rate [m/s] + ! seta = ep5*(1.0-sal/sf) !rt thinks this is not needed; TR: Why different to M_b? LIQUID vs. ICE + + !rt t_surf_flux(i,j)=gat*(tf-tin) + !rt s_surf_flux(i,j)=gas*(sf-(s(i,j,N,lrhs)+35.0)) + + !heat_flux_ib(ib) = rhow*cpw*gat*(tin-tf)*scaling(ib) ! [W/m2] ! positive for upward + heat_flux_ib(ib) = rhow*cpw*gat*(tin-tf)*length_ib(ib)*width_ib(ib)*scaling(ib) ! [W] ! positive for upward + !fw_flux_ib(ib) = gas*(sf-sal)/sf ! [m/s] ! + M_b = gas*(sf-sal)/sf ! [m/s] ! m freshwater per second + !fw_flux_ib(ib) = M_b + !fw = -M_b + M_b = - (rhow / rhoi) * M_b ! [m (ice) per second], positive for melting? NOW positive for melting + + !LA avoid basal freezing for grounded icebergs + if(M_b.lt.0.) then + M_b = 0.0 + endif + + ! qo=-rhor*seta*oofw + ! if(seta.le.0.) then + ! qc=rhor*seta*hemw + ! qo=rhor*seta*oomw + ! endif + + ! write(*,'(a10,i10,9f10.3)') 'ice shelf',n,zice,rhow,temp,sal,tin,tf,sf,heat_flux(n),water_flux(n)*86400.*365. + + !for saving to output: + !net_heat_flux(n)=-heat_flux(n) ! positive down + !fresh_wa_flux(n)=-water_flux(n) ! m freshwater per second + + !enddo + +end subroutine iceberg_heat_water_fluxes_3eq + +subroutine potit_ib(ib,salz,pt,pres,rfpres,tin) + ! Berechnet aus dem Salzgehalt[psu] (SALZ), der pot. Temperatur[oC] + ! (PT) und dem Referenzdruck[dbar] (REFPRES) die in-situ Temperatur + ! [oC] (TIN) bezogen auf den in-situ Druck[dbar] (PRES) mit Hilfe + ! eines Iterationsverfahrens aus. + + integer ib + integer iter + real salz,pt,pres,rfpres,tin + real epsi,tpmd,pt1,ptd,pttmpr + + data tpmd / 0.001 / + + epsi = 0. + do iter=1,100 + tin = pt+epsi + pt1 = pttmpr(salz,tin,pres,rfpres) + ptd = pt1-pt + if(abs(ptd).lt.tpmd) return + epsi = epsi-ptd + enddo + write(*,*) ' WARNING FOR ICEBERG #',ib + write(*,*) ' in-situ temperature calculation has not converged.' + write(*,*) ' values: salt ', salz,', pot. temp ',pt, ', pressure ', pres, ', refpressure ', rfpres, ', temp ', tin + stop + return +end subroutine potit_ib + +! if the underlying FESOM is run without cavities, the following routines might be +! missing, so put them here: +#ifndef use_cavity +! +!------------------------------------------------------------------------------------- +! +!subroutine potit(salz,pt,pres,rfpres,tin) +! ! Berechnet aus dem Salzgehalt[psu] (SALZ), der pot. Temperatur[oC] +! ! (PT) und dem Referenzdruck[dbar] (REFPRES) die in-situ Temperatur +! ! [oC] (TIN) bezogen auf den in-situ Druck[dbar] (PRES) mit Hilfe +! ! eines Iterationsverfahrens aus. +! +! integer iter +! real salz,pt,pres,rfpres,tin +! real epsi,tpmd,pt1,ptd,pttmpr +! +! data tpmd / 0.001 / +! +! epsi = 0. +! do iter=1,100 +! tin = pt+epsi +! pt1 = pttmpr(salz,tin,pres,rfpres) +! ptd = pt1-pt +! if(abs(ptd).lt.tpmd) return +! epsi = epsi-ptd +! enddo +! write(6,*) ' WARNING!' +! write(6,*) ' in-situ temperature calculation has not converged.' +! stop +! return +!end subroutine potit +! +!------------------------------------------------------------------------------------- +! +!real function pttmpr(salz,temp,pres,rfpres) +! ! Berechnet aus dem Salzgehalt/psu (SALZ), der in-situ Temperatur/degC +! ! (TEMP) und dem in-situ Druck/dbar (PRES) die potentielle Temperatur/ +! ! degC (PTTMPR) bezogen auf den Referenzdruck/dbar (RFPRES). Es wird +! ! ein Runge-Kutta Verfahren vierter Ordnung verwendet. +! ! Checkwert: PTTMPR = 36.89073 DegC +! ! fuer SALZ = 40.0 psu +! ! TEMP = 40.0 DegC +! ! PRES = 10000.000 dbar +! ! RFPRES = 0.000 dbar +! +! data ct2 ,ct3 /0.29289322 , 1.707106781/ +! data cq2a,cq2b /0.58578644 , 0.121320344/ +! data cq3a,cq3b /3.414213562, -4.121320344/ +! +! real salz,temp,pres,rfpres +! real p,t,dp,dt,q,ct2,ct3,cq2a,cq2b,cq3a,cq3b +! real adlprt +! +! p = pres +! t = temp +! dp = rfpres-pres +! dt = dp*adlprt(salz,t,p) +! t = t +0.5*dt +! q = dt +! p = p +0.5*dp +! dt = dp*adlprt(salz,t,p) +! t = t + ct2*(dt-q) +! q = cq2a*dt + cq2b*q +! dt = dp*adlprt(salz,t,p) +! t = t + ct3*(dt-q) +! q = cq3a*dt + cq3b*q +! p = rfpres +! dt = dp*adlprt(salz,t,p) +! +! pttmpr = t + (dt-q-q)/6.0 +! +!end function pttmpr +! +!------------------------------------------------------------------------------------- +! +!real function adlprt(salz,temp,pres) +! ! Berechnet aus dem Salzgehalt/psu (SALZ), der in-situ Temperatur/degC +! ! (TEMP) und dem in-situ Druck/dbar (PRES) den adiabatischen Temperatur- +! ! gradienten/(K Dbar^-1) ADLPRT. +! ! Checkwert: ADLPRT = 3.255976E-4 K dbar^-1 +! ! fuer SALZ = 40.0 psu +! ! TEMP = 40.0 DegC +! ! PRES = 10000.000 dbar +! +! real salz,temp,pres +! real s0,a0,a1,a2,a3,b0,b1,c0,c1,c2,c3,d0,d1,e0,e1,e2,ds +! +! data s0 /35.0/ +! data a0,a1,a2,a3 /3.5803E-5, 8.5258E-6, -6.8360E-8, 6.6228E-10/ +! data b0,b1 /1.8932E-6, -4.2393E-8/ +! data c0,c1,c2,c3 /1.8741E-8, -6.7795E-10, 8.7330E-12, -5.4481E-14/ +! data d0,d1 /-1.1351E-10, 2.7759E-12/ +! data e0,e1,e2 /-4.6206E-13, 1.8676E-14, -2.1687E-16/ +! +! ds = salz-s0 +! adlprt = ( ( (e2*temp + e1)*temp + e0 )*pres & +! + ( (d1*temp + d0)*ds & +! + ( (c3*temp + c2)*temp + c1 )*temp + c0 ) )*pres & +! + (b1*temp + b0)*ds + ( (a3*temp + a2)*temp + a1 )*temp + a0 +! +!END function adlprt +! +!---------------------------------------------------------------------------------------- +! +#endif + + +! LA from oce_dens_press for iceberg coupling +subroutine fcn_density(t,s,z,rho) + ! The function to calculate insitu density as a function of + ! potential temperature (t is relative to the surface) + ! using the Jackett and McDougall equation of state (1992??) + ! + ! Should this be updated (1995 or 2003)? The current version is also + ! different to the international equation of state (Unesco 1983). + ! What is the exact reference for this version then? + ! A question mark from Qiang 02,07,2010. + ! + ! Coded by ?? + ! Reviewed by ?? + !------------------------------------------------------------------- + + + use o_PARAM + implicit none + + real(kind=8), intent(IN) :: t, s, z + real(kind=8), intent(OUT) :: rho + real(kind=8) :: rhopot, bulk + + bulk = 19092.56 + t*(209.8925 & + - t*(3.041638 - t*(-1.852732e-3 & + - t*(1.361629e-5)))) & + + s*(104.4077 - t*(6.500517 & + - t*(.1553190 - t*(-2.326469e-4)))) & + + sqrt(s**3)*(-5.587545 & + + t*(0.7390729 - t*(1.909078e-2))) & + - z *(4.721788e-1 + t*(1.028859e-2 & + + t*(-2.512549e-4 - t*(5.939910e-7)))) & + - z*s*(-1.571896e-2 & + - t*(2.598241e-4 + t*(-7.267926e-6))) & + - z*sqrt(s**3) & + *2.042967e-3 + z*z*(1.045941e-5 & + - t*(5.782165e-10 - t*(1.296821e-7))) & + + z*z*s & + *(-2.595994e-7 & + + t*(-1.248266e-9 + t*(-3.508914e-9))) + + rhopot = ( 999.842594 & + + t*( 6.793952e-2 & + + t*(-9.095290e-3 & + + t*( 1.001685e-4 & + + t*(-1.120083e-6 & + + t*( 6.536332e-9))))) & + + s*( 0.824493 & + + t *(-4.08990e-3 & + + t *( 7.64380e-5 & + + t *(-8.24670e-7 & + + t *( 5.38750e-9))))) & + + sqrt(s**3)*(-5.72466e-3 & + + t*( 1.02270e-4 & + + t*(-1.65460e-6))) & + + 4.8314e-4*s**2) + rho = rhopot / (1.0 + 0.1*z/bulk) +end subroutine fcn_density diff --git a/src/ice_oce_coupling.F90 b/src/ice_oce_coupling.F90 index ca20df96c..4bf4bd0ee 100755 --- a/src/ice_oce_coupling.F90 +++ b/src/ice_oce_coupling.F90 @@ -251,7 +251,7 @@ subroutine oce_fluxes(ice, dynamics, tracers, partit, mesh) use g_CONFIG use o_ARRAYS use g_comm_auto - use g_forcing_param, only: use_virt_salt + use g_forcing_param, only: use_virt_salt, use_landice_water, use_age_tracer, use_age_mask, age_start_year !---fwf-code, age-code use g_forcing_arrays use g_support use cavity_interfaces @@ -260,6 +260,10 @@ subroutine oce_fluxes(ice, dynamics, tracers, partit, mesh) init_flux_atm_ocn #endif use cavity_interfaces + !---fwf-code + use g_clock + !---fwf-code-end + implicit none type(t_ice) , intent(inout), target :: ice type(t_dyn) , intent(in) , target :: dynamics @@ -277,6 +281,18 @@ subroutine oce_fluxes(ice, dynamics, tracers, partit, mesh) real(kind=WP), dimension(:) , pointer :: thdgr, thdgrsn real(kind=WP), dimension(:) , pointer :: fresh_wa_flux, net_heat_flux real(kind=WP) , pointer :: rhoice, rhosno, inv_rhowat + + !---wiso-code + integer :: nt + real(kind=WP), dimension(:,:), pointer :: wiso_oce1, wiso_oce2, wiso_oce3 + real(kind=WP), dimension(3) :: zfrac_freezing + real(kind=WP), parameter :: zwisomin = 1.e-6_WP + real(kind=WP), allocatable :: snmelt(:), icemelt(:) + real(kind=WP), allocatable :: wiso_prec_o16(:) + real(kind=WP), allocatable :: wiso_rain(:,:), wiso_snow(:,:), wiso_melt(:,:) + real(kind=WP), allocatable :: wiso_delta_rain(:,:),wiso_delta_snow(:,:),wiso_delta_ocean(:,:),wiso_delta_seaice(:,:) + !---wiso-code-end + #include "associate_part_def.h" #include "associate_mesh_def.h" #include "associate_part_ass.h" @@ -304,6 +320,24 @@ subroutine oce_fluxes(ice, dynamics, tracers, partit, mesh) end do !$OMP END PARALLEL DO + !---wiso-code + if (lwiso) then + wiso_oce1 => tracers%data(index_wiso_tracers(1))%values(:,:) + wiso_oce2 => tracers%data(index_wiso_tracers(2))%values(:,:) + wiso_oce3 => tracers%data(index_wiso_tracers(3))%values(:,:) + allocate(snmelt(myDim_nod2D+eDim_nod2D)) + allocate(icemelt(myDim_nod2D+eDim_nod2D)) + allocate(wiso_prec_o16(myDim_nod2D+eDim_nod2D)) + allocate(wiso_rain(myDim_nod2D+eDim_nod2D,3)) + allocate(wiso_snow(myDim_nod2D+eDim_nod2D,3)) + allocate(wiso_melt(myDim_nod2D+eDim_nod2D,3)) + allocate(wiso_delta_rain(myDim_nod2D+eDim_nod2D,3)) + allocate(wiso_delta_snow(myDim_nod2D+eDim_nod2D,3)) + allocate(wiso_delta_ocean(myDim_nod2D+eDim_nod2D,3)) + allocate(wiso_delta_seaice(myDim_nod2D+eDim_nod2D,3)) + end if + !---wiso-code-end + ! ================== ! heat and freshwater ! ================== @@ -476,12 +510,27 @@ subroutine oce_fluxes(ice, dynamics, tracers, partit, mesh) -ice_sublimation(n) & ! the ice2atmos subplimation does not contribute to the freshwater flux into the ocean +prec_rain(n) & +prec_snow(n)*(1.0_WP-a_ice_old(n)) & -#if defined (__oifs) +#if defined (__oasis) || defined (__ifsinterface) +residualifwflx(n) & ! balance residual ice flux only in coupled case #endif - +runoff(n) + +runoff(n) +#if defined (__oasis) || defined (__ifsinterface) +! in the coupled mode the computation of freshwater flux takes into account the ratio between freshwater & salt water + flux(n) = flux(n)*ice%thermo%rhofwt/ice%thermo%rhowat +#endif end do !$OMP END PARALLEL DO + + !---wiso-code + if (lwiso) then + ! calculate snow melt (> 0.) and sea ice melt/growth (melt: > 0.; growth < 0.) as fraction of freshwater flux into the ocean + snmelt = 0._WP + icemelt = 0._WP + where (abs(flux) > zwisomin) snmelt = -(thdgrsn*rhosno*inv_rhowat)/abs(flux) + where (abs(flux) > zwisomin) icemelt = -(thdgr*rhoice*inv_rhowat)/abs(flux) + end if + !---wiso-code-end + ! --> In case of zlevel and zstar and levitating sea ice, sea ice is just sitting ! on top of the ocean without displacement of water, there the thermodynamic ! growth rates of sea ice have to be taken into account to preserve the fresh water @@ -544,6 +593,26 @@ subroutine oce_fluxes(ice, dynamics, tracers, partit, mesh) !$OMP END PARALLEL DO end if +!---fwf-code-begin + if(use_landice_water) then +!$OMP PARALLEL DO + do n=1, myDim_nod2D+eDim_nod2D + water_flux(n)=water_flux(n)-runoff_landice(n)*landice_season(month) + end do +!$OMP END PARALLEL DO + end if + +! if(lwiso .and. use_landice_water) then +!!$OMP PARALLEL DO +! do n=1, myDim_nod2D+eDim_nod2D +! wiso_flux_oce(n,1)=wiso_flux_oce(n,1)+runoff_landice(n)*1000.0*wiso_smow(1)*(1-30.0/1000.0)*landice_season(month) +! wiso_flux_oce(n,2)=wiso_flux_oce(n,2)+runoff_landice(n)*1000.0*wiso_smow(2)*(1-240.0/1000.0)*landice_season(month) +! wiso_flux_oce(n,3)=wiso_flux_oce(n,3)+runoff_landice(n)*1000.0*landice_season(month) +! end do +!!$OMP END PARALLEL DO +! end if +!---fwf-code-end + !___________________________________________________________________________ ! use the balanced water_flux and relax_salt flux (same as in the tracer ! boundary condition) to compute the dens_flux for MOC diagnostic @@ -557,6 +626,170 @@ subroutine oce_fluxes(ice, dynamics, tracers, partit, mesh) end do !$OMP END PARALLEL DO + !---wiso-code + + if (lwiso) then + + ! *** Important ***: The following wiso tracer order is assumed: nt=1: H218O, nt=2: HDO, nt=3: H216O + + + ! (i) calculate isotope fluxes (received from coupled atmosphere model) into open water and onto sea ice + + ! atmospheric total H216O flux over open water and sea ice + wiso_prec_o16 = (www3+iii3)*1000._WP + ! integrate total H2O fluxes over all nodes for following flux corrections + call integrate_nod(wiso_prec_o16, net, partit, mesh) + + nt=3 + wiso_rain(:,nt)=www3*1000._WP ! atmospheric H216O flux over open water + wiso_flux_oce(:,nt)=wiso_rain(:,nt)-net/ocean_area ! correction to enforce total H216O flux be zero + + do nt=1,2 + if (nt .EQ. 1) wiso_rain(:,nt)=www1*1000._WP/((20._WP/18._WP)*100._WP) ! atmospheric H218O flux over open water + if (nt .EQ. 2) wiso_rain(:,nt)=www2*1000._WP/((19._WP/18._WP)*2._WP*1000._WP) ! atmospheric HDO flux over open water + wiso_delta_rain(:,nt)=wiso_smow(nt) + where (abs(wiso_rain(:,3)).gt.zwisomin) wiso_delta_rain(:,nt) = wiso_rain(:,nt)/wiso_rain(:,3) + wiso_flux_oce(:,nt) = wiso_delta_rain(:,nt) * wiso_flux_oce(:,3) ! flux into ocean: assume same delta as atmospheric flux + end do + + nt=3 + wiso_snow(:,nt)=iii3*1000._WP ! atmospheric H216O flux over sea ice + wiso_flux_ice(:,nt)=wiso_snow(:,nt)-net/ocean_area ! correction to enforce total H216O flux be zero + where (a_ice(:).le.0.001_WP) wiso_flux_ice(:,nt)=0.0_WP ! limit corrected H216O flux to sea ice areas, only + + do nt=1,2 + if (nt .EQ. 1) wiso_snow(:,nt)=iii1*1000._WP/((20._WP/18._WP)*100._WP) ! atmospheric H218O flux over sea ice + if (nt .EQ. 2) wiso_snow(:,nt)=iii2*1000._WP/((19._WP/18._WP)*2._WP*1000._WP) ! atmospheric HDO flux over sea ice + wiso_delta_snow(:,nt)=wiso_smow(nt) + where (abs(wiso_snow(:,3)).gt.zwisomin) wiso_delta_snow(:,nt) = wiso_snow(:,nt)/wiso_snow(:,3) + wiso_flux_ice(:,nt) = wiso_delta_snow(:,nt) * wiso_flux_ice(:,3) ! flux onto sea ice: assume same delta as atmospheric flux + end do + + + ! (ii) balance isotope fluxes for growing/melting of sea ice and melting of snow on sea ice + + ! set delta values of various H216O water masses to SMOW(O16) (=1.) + nt=3 + wiso_delta_ocean(:,nt)=wiso_smow(nt) + wiso_delta_seaice(:,nt)=wiso_smow(nt) + wiso_delta_snow(:,nt)=wiso_smow(nt) + + ! calculate delta values of ocean surface water and sea ice for H218O and HDO + nt=1 + do n=1, myDim_nod2D+eDim_nod2D + ! calculate delta of open water (top ocean level) + wiso_delta_ocean(n,nt)=wiso_smow(nt) + if (wiso_oce3(1,n).gt.zwisomin) wiso_delta_ocean(n,nt) = wiso_oce1(1,n)/wiso_oce3(1,n) + ! calculate delta of sea ice + wiso_delta_seaice(n,nt)=wiso_smow(nt) + if (tr_arr_ice(n,3).gt.zwisomin) wiso_delta_seaice(n,nt) = tr_arr_ice(n,nt)/tr_arr_ice(n,3) + end do + + nt=2 + do n=1, myDim_nod2D+eDim_nod2D + ! calculate delta of open water (top ocean level) + wiso_delta_ocean(n,nt)=wiso_smow(nt) + if (wiso_oce3(1,n).gt.zwisomin) wiso_delta_ocean(n,nt) = wiso_oce2(1,n)/wiso_oce3(1,n) + ! calculate delta of sea ice + wiso_delta_seaice(n,nt)=wiso_smow(nt) + if (tr_arr_ice(n,3).gt.zwisomin) wiso_delta_seaice(n,nt) = tr_arr_ice(n,nt)/tr_arr_ice(n,3) + end do + + ! for melting of snow on seaice (snmelt > 0.): assume no fractionation during melting process + wiso_melt(:,:) = 0.0_WP + + nt=3 + wiso_melt(:,nt) = snmelt(:) * abs(wiso_flux_oce(:,nt)) ! H216O melt amount = snow melt fraction x H216O freshwater flux over ocean + wiso_melt(:,nt) = max(min(wiso_melt(:,nt),wiso_flux_ice(:,nt)),0._WP) ! limit snow melt amount to range (0...wiso_flux_ice) + where (a_ice(:).le.0.001_WP) wiso_melt(:,nt)=0.0_WP ! limit isotope changes by snow melt to sea ice areas, only + + do nt=1,2 + ! H218O and HDO meltwater has the same isotope ratio as snow on sea ice; no fractionation during melting + wiso_melt(:,nt) = wiso_delta_snow(:,nt) * wiso_melt(:,3) + end do + + wiso_flux_oce(:,:)= wiso_flux_oce(:,:) + wiso_melt(:,:) + wiso_flux_ice(:,:)= wiso_flux_ice(:,:) - wiso_melt(:,:) + + ! for melting of seaice (icemelt > 0.): assume no fractionation during melting process + ! for growing of seaice (icemelt < 0.): assume fractionation during freezing process + ! (use equilibrium fractionation factors by Lehmann & Siegenthaler, JofGlaciology, 1991) + zfrac_freezing = (/1.00291_WP, 1.0212_WP, 1.0_WP/) + wiso_melt(:,:) = 0.0_WP + + nt=3 + wiso_melt(:,nt) = icemelt(:) * abs(wiso_flux_oce(:,nt)) ! H216O melt (or growth) amount = sea ice melt fraction x H216O freshwater flux over ocean + where (a_ice(:).le.0.001_WP) wiso_melt(:,nt)=0.0_WP ! limit isotope changes by melting/growing of sea ice to sea ice areas, only + + do nt=1,2 + ! H218O and HDO meltwater has the same isotope ratio as sea ice; no fractionation during melting + where (wiso_melt(:,3) > 0.0_WP) wiso_melt(:,nt) = wiso_delta_seaice(:,nt) * wiso_melt(:,3) + ! newly formed H218O and HDO sea ice has isotope ratio of ocean water; fractionation during growing considered + where (wiso_melt(:,3) < 0.0_WP) wiso_melt(:,nt) = wiso_delta_ocean(:,nt) * wiso_melt(:,3) * zfrac_freezing(nt) + end do + + wiso_flux_oce(:,:)= wiso_flux_oce(:,:) + wiso_melt(:,:) + wiso_flux_ice(:,:)= wiso_flux_ice(:,:) - wiso_melt(:,:) + + ! here: update sea ice isotope tracer concentration, only + ! sea ice isotope tracer concentration are limited to sea ice areas, only + ! (ocean water isotope tracers are updated in routine *oce_ale_tracer*) + do n=1, myDim_nod2D+eDim_nod2D + tr_arr_ice(n,:) = tr_arr_ice(n,:) + dt*wiso_flux_ice(n,:) + end do + + do n=1, myDim_nod2D+eDim_nod2D + if (tr_arr_ice(n,3) .gt. 1500._WP) then ! check if H216O tracer concentration reaches (arbitrary) limit of 1500. + tr_arr_ice(n,1) = 1500._WP*tr_arr_ice(n,1)/tr_arr_ice(n,3) ! reduce H2O18 based on the original ratio between H2O18 and H2O16 (i.e. the delta values are not changed) + tr_arr_ice(n,2) = 1500._WP*tr_arr_ice(n,2)/tr_arr_ice(n,3) ! reduce HDO16 based on the original ratio between HDO16 and H2O16 (i.e. the delta values are not changed) + tr_arr_ice(n,3) = 1500._WP ! reduce H216O to (arbitrary) upper limit + endif + end do + + do n=1, myDim_nod2D+eDim_nod2D + if (tr_arr_ice(n,3) .le. 1._WP) then ! check if H216O tracer concentration becomes too small or even negative + tr_arr_ice(n,1) = wiso_smow(1) ! set delta H2O18 to SMOW value + tr_arr_ice(n,2) = wiso_smow(2) ! set delta HDO16 to SMOW value + tr_arr_ice(n,3) = 1._WP ! set H216O to lower limit + endif + end do + + end if ! lwiso end + + !---wiso-code-end + + !---fwf-code-begin + if(use_landice_water) then + do n=1, myDim_nod2D+eDim_nod2D + water_flux(n)=water_flux(n)-runoff_landice(n)*landice_season(month) + end do + end if + + if(lwiso .and. use_landice_water) then + do n=1, myDim_nod2D+eDim_nod2D + wiso_flux_oce(n,1)=wiso_flux_oce(n,1)+runoff_landice(n)*1000.0*wiso_smow(1)*(1-30.0/1000.0)*landice_season(month) + wiso_flux_oce(n,2)=wiso_flux_oce(n,2)+runoff_landice(n)*1000.0*wiso_smow(2)*(1-240.0/1000.0)*landice_season(month) + wiso_flux_oce(n,3)=wiso_flux_oce(n,3)+runoff_landice(n)*1000.0*landice_season(month) + end do + end if + !---fwf-code-end + + !---age-code-begin + if (use_age_tracer) then + tracers%data(index_age_tracer)%values(:,:) = tracers%data(index_age_tracer)%values(:,:) + dt/(86400.0*(365+fleapyear)) + + if (use_age_mask) then + tracers%data(index_age_tracer)%values(1,:) = tracers%data(index_age_tracer)%values(1,:) * (1-age_tracer_loc_index(:)) + else + tracers%data(index_age_tracer)%values(1,:) = 0.0 + end if + + where (tracers%data(index_age_tracer)%values(:,:) .gt. yearnew-age_start_year+1) + tracers%data(index_age_tracer)%values(:,:) = yearnew-age_start_year+1 + end where + end if + !---age-code-end + !___________________________________________________________________________ if (use_sw_pene) call cal_shortwave_rad(ice, partit, mesh) diff --git a/src/ice_setup_step.F90 b/src/ice_setup_step.F90 index d0a575802..663e8e954 100755 --- a/src/ice_setup_step.F90 +++ b/src/ice_setup_step.F90 @@ -122,15 +122,55 @@ subroutine ice_timestep(step, ice, partit, mesh) !___________________________________________________________________________ ! pointer on necessary derived types real(kind=WP), dimension(:), pointer :: u_ice, v_ice + !LA 2023-03-08 + real(kind=WP), dimension(:), pointer :: u_ice_ib, v_ice_ib #if defined (__oifs) || defined (__ifsinterface) real(kind=WP), dimension(:), pointer :: ice_temp, a_ice + !LA 2023-03-08 + real(kind=WP), dimension(:), pointer :: a_ice_ib #endif #include "associate_part_def.h" #include "associate_mesh_def.h" #include "associate_part_ass.h" #include "associate_mesh_ass.h" - u_ice => ice%uice(:) - v_ice => ice%vice(:) + +!--------------------------------------------- +! LA: 2023-01-31 add asynchronous icebergs +! u_ice => ice%uice(:) +! v_ice => ice%vice(:) +! kh 19.02.21 + if (ib_async_mode == 0) then + u_ice => ice%uice(:) + v_ice => ice%vice(:) + !allocate(u_ice(n_size), v_ice(n_size)) + !allocate(u_ice_ib(n_size), v_ice_ib(n_size)) + else +!$omp parallel sections num_threads(2) +! kh 19.02.21 support "first touch" idea +!$omp section + u_ice => ice%uice(:) + v_ice => ice%vice(:) + !allocate(u_ice(n_size), v_ice(n_size)) + u_ice = 0._WP + v_ice = 0._WP + !do i = 1, n_size + ! u_ice(i) = 0._WP + ! v_ice(i) = 0._WP + !end do +!$omp section + u_ice_ib => ice%uice_ib(:) + v_ice_ib => ice%vice_ib(:) + !allocate(u_ice_ib(n_size), v_ice_ib(n_size)) + u_ice_ib = 0._WP + v_ice_ib = 0._WP + !do i = 1, n_size + ! u_ice_ib(i) = 0._WP + ! v_ice_ib(i) = 0._WP + !end do +!$omp end parallel sections + end if +!--------------------------------------------- + #if defined (__oifs) || defined (__ifsinterface) a_ice => ice%data(1)%values(:) ice_temp => ice%data(4)%values(:) @@ -301,10 +341,19 @@ subroutine ice_initial_state(ice, tracers, partit, mesh) ! pointer on necessary derived types real(kind=WP), dimension(:), pointer :: a_ice, m_ice, m_snow real(kind=WP), dimension(:), pointer :: u_ice, v_ice + !LA 2023-03-07 + real(kind=WP), dimension(:), pointer :: a_ice_ib, m_ice_ib + real(kind=WP), dimension(:), pointer :: u_ice_ib, v_ice_ib #include "associate_part_def.h" #include "associate_mesh_def.h" #include "associate_part_ass.h" #include "associate_mesh_ass.h" + +! LA: 2023-01-31 add asynchronous icebergs +!--------------------------------------------- +m_snow => ice%data(3)%values(:) +m_snow=0._WP +if (.not.use_icebergs) then u_ice => ice%uice(:) v_ice => ice%vice(:) a_ice => ice%data(1)%values(:) @@ -315,7 +364,69 @@ subroutine ice_initial_state(ice, tracers, partit, mesh) a_ice =0._WP u_ice =0._WP v_ice =0._WP - m_snow=0._WP +else + if (ib_async_mode == 0) then + u_ice => ice%uice(:) + v_ice => ice%vice(:) + u_ice_ib => ice%uice_ib(:) + v_ice_ib => ice%vice_ib(:) + a_ice => ice%data(1)%values(:) + m_ice => ice%data(2)%values(:) + a_ice_ib => ice%data(size(ice%data)-1)%values(:) + m_ice_ib => ice%data(size(ice%data))%values(:) + !allocate(m_ice(n_size), a_ice(n_size)) + !allocate(m_ice_ib(n_size), a_ice_ib(n_size)) + m_ice = 0._WP + a_ice = 0._WP + u_ice = 0._WP + v_ice = 0._WP + u_ice_ib = 0._WP + v_ice_ib = 0._WP + m_ice_ib = 0._WP + a_ice_ib = 0._WP + else +! kh 19.02.21 support "first touch" idea +!$omp parallel sections num_threads(2) +!$omp section + !allocate(m_ice(n_size), a_ice(n_size)) + !do i = 1, n_size + ! m_ice(i) = 0._WP + ! a_ice(i) = 0._WP + !end do + u_ice => ice%uice(:) + v_ice => ice%vice(:) + a_ice => ice%data(1)%values(:) + m_ice => ice%data(2)%values(:) + !allocate(m_ice(n_size), a_ice(n_size)) + !allocate(m_ice_ib(n_size), a_ice_ib(n_size)) + m_ice = 0._WP + a_ice = 0._WP + u_ice = 0._WP + v_ice = 0._WP +!$omp section + !allocate(m_ice_ib(n_size), a_ice_ib(n_size)) + !do i = 1, n_size + ! m_ice_ib(i) = 0._WP + ! a_ice_ib(i) = 0._WP + !end do + u_ice_ib => ice%uice_ib(:) + v_ice_ib => ice%vice_ib(:) + a_ice_ib => ice%data(size(ice%data)-1)%values(:) + m_ice_ib => ice%data(size(ice%data))%values(:) + !allocate(m_ice(n_size), a_ice(n_size)) + !allocate(m_ice_ib(n_size), a_ice_ib(n_size)) + u_ice_ib = 0._WP + v_ice_ib = 0._WP + m_ice_ib = 0._WP + a_ice_ib = 0._WP +!$omp end parallel sections + end if +end if +! LA: 2023-01-31 add asynchronous icebergs +!--------------------------------------------- + + + !___________________________________________________________________________ ! OPEN and read namelist for I/O open( unit=nm_ic_unit, file='namelist.tra', form='formatted', access='sequential', status='old', iostat=iost ) diff --git a/src/ice_thermo_cpl.F90 b/src/ice_thermo_cpl.F90 index 3c3dcda0a..a55e8d053 100644 --- a/src/ice_thermo_cpl.F90 +++ b/src/ice_thermo_cpl.F90 @@ -72,7 +72,7 @@ subroutine thermodynamics(ice, partit, mesh) #if defined (__oasis) || defined (__ifsinterface) real(kind=WP), dimension(:) , pointer :: oce_heat_flux, ice_heat_flux #endif - real(kind=WP) , pointer :: rhoice, rhosno, rhowat, Sice, cl, cc, cpice, consn, con + real(kind=WP) , pointer :: rhoice, rhosno, rhowat, rhofwt, Sice, cl, cc, cpice, consn, con myDim_nod2d=>partit%myDim_nod2D eDim_nod2D =>partit%eDim_nod2D ulevels_nod2D (1 :myDim_nod2D+eDim_nod2D) => mesh%ulevels_nod2D @@ -106,6 +106,7 @@ subroutine thermodynamics(ice, partit, mesh) rhoice => ice%thermo%rhoice rhosno => ice%thermo%rhosno rhowat => ice%thermo%rhowat + rhofwt => ice%thermo%rhofwt Sice => ice%thermo%Sice cl => ice%thermo%cl cc => ice%thermo%cc @@ -192,10 +193,7 @@ subroutine thermodynamics(ice, partit, mesh) !---- total evaporation (needed in oce_salt_balance.F90) = evap+subli evaporation(inod) = evap + subli ice_sublimation(inod)= subli - prec_rain(inod) = rain - prec_snow(inod) = snow - runoff(inod) = runo -#if defined (__oifs) +#if defined (__oasis) || defined (__ifsinterface) residualifwflx(inod) = resid #endif enddo @@ -244,9 +242,6 @@ subroutine ice_growth !---- significantly greater than the time step dt real(kind=WP), parameter :: gamma_t = 10./86400. - !---- density of freshwater [kg/m**3]. - real(kind=WP), parameter :: rhofwt = 1000. - !---- freezing temperature of freshwater [deg C] real(kind=WP), parameter :: Tfrez0 = 0. @@ -482,12 +477,13 @@ subroutine ice_growth !---- convert freshwater mass flux [kg/m**2/s] into sea-water volume flux [m/s] fw = fw/rhowat - evap = evap *rhofwt/rhowat - rain = rain *rhofwt/rhowat - snow = snow *rhofwt/rhowat - runo = runo *rhofwt/rhowat - subli= subli*rhofwt/rhowat - resid= resid*rhofwt/rhowat + ! keep in mind that for computation of FW all imposed fluxes were accounted with the ratio rhofwt/rhowat: + !evap = evap *rhofwt/rhowat + !rain = rain *rhofwt/rhowat + !snow = snow *rhofwt/rhowat + !runo = runo *rhofwt/rhowat + !subli= subli*rhofwt/rhowat + !resid= resid*rhofwt/rhowat return end subroutine ice_growth diff --git a/src/io_meandata.F90 b/src/io_meandata.F90 index 14daf4ed2..84de9d848 100644 --- a/src/io_meandata.F90 +++ b/src/io_meandata.F90 @@ -111,6 +111,10 @@ subroutine destructor(this) !_______________________________________________________________________________ ! define 2d/3d meandata stream parameter subroutine ini_mean_io(ice, dynamics, tracers, partit, mesh) + !------------------------------------------ + ! LA 2023-01-31 add iceberg params + use iceberg_params + !------------------------------------------ use MOD_MESH use MOD_TRACER USE MOD_PARTIT @@ -123,7 +127,8 @@ subroutine ini_mean_io(ice, dynamics, tracers, partit, mesh) use g_cvmix_tidal use diagnostics use g_config, only: use_cavity - use g_forcing_param, only: use_virt_salt + use g_forcing_param, only: use_virt_salt, use_landice_water, use_age_tracer !---fwf-code, age-code + use g_config, only : lwiso !---wiso-code implicit none integer :: i, j integer, save :: nm_io_unit = 103 ! unit to open namelist file, skip 100-102 for cray @@ -313,6 +318,37 @@ subroutine ini_mean_io(ice, dynamics, tracers, partit, mesh) CASE ('MLD3 ') call def_stream(nod2D, myDim_nod2D, 'MLD3', 'Mixed Layer Depth', 'm', MLD3(1:myDim_nod2D), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) +!_______________________________________________________________________________ +!---wiso-code +! output water isotopes in sea ice +CASE ('h2o18_ice ') + if (lwiso) then + call def_stream(nod2D, myDim_nod2D, 'h2o18_ice', 'h2o18 concentration in sea ice', 'kmol/m**3', tr_arr_ice(:,1), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + endif +CASE ('hDo16_ice ') + if (lwiso) then + call def_stream(nod2D, myDim_nod2D, 'hDo16_ice', 'hDo16 concentration in sea ice', 'kmol/m**3', tr_arr_ice(:,2), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + endif +CASE ('h2o16_ice ') + if (lwiso) then + call def_stream(nod2D, myDim_nod2D, 'h2o16_ice', 'h2o16 concentration in sea ice', 'kmol/m**3', tr_arr_ice(:,3), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + endif +!---wiso-code-end + +!---fwf-code-begin +CASE ('landice ') + if (use_landice_water) then + call def_stream(nod2D, myDim_nod2D, 'landice', 'freshwater flux', 'm/s', runoff_landice, io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + endif +!---fwf-code-end + +!---age-code-begin +CASE ('age ') + if (use_age_tracer) then + call def_stream((/nl-1, nod2D/), (/nl-1, myDim_nod2D/), 'age', 'water age tracer', 'year', tracers%data(index_age_tracer)%values(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if +!---age-code-end + !_______________________________________________________________________________ ! output surface forcing CASE ('fh ') @@ -412,6 +448,22 @@ subroutine ini_mean_io(ice, dynamics, tracers, partit, mesh) call def_stream((/nl-1, nod2D/), (/nl-1, myDim_nod2D/), 'temp', 'temperature', 'C', tracers%data(1)%values(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) CASE ('salt ') call def_stream((/nl-1, nod2D/), (/nl-1, myDim_nod2D/), 'salt', 'salinity', 'psu', tracers%data(2)%values(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) +!---wiso-code +!___________________________________________________________________________________________________________________________________ +! output water isotopes in ocean water +CASE ('h2o18 ') + if (lwiso) then + call def_stream((/nl-1, nod2D/), (/nl-1, myDim_nod2D/), 'h2o18', 'h2o18 concentration', 'kmol/m**3', tracers%data(index_wiso_tracers(1))%values(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if +CASE ('hDo16 ') + if (lwiso) then + call def_stream((/nl-1, nod2D/), (/nl-1, myDim_nod2D/), 'hDo16', 'hDo16 concentration', 'kmol/m**3', tracers%data(index_wiso_tracers(2))%values(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if +CASE ('h2o16 ') + if (lwiso) then + call def_stream((/nl-1, nod2D/), (/nl-1, myDim_nod2D/), 'h2o16', 'h2o16 concentration', 'kmol/m**3', tracers%data(index_wiso_tracers(3))%values(:,:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) + end if +!---wiso-code-end CASE ('otracers ') do j=3, tracers%num_tracers write (id_string, "(I3.3)") tracers%data(j)%ID @@ -539,6 +591,18 @@ subroutine ini_mean_io(ice, dynamics, tracers, partit, mesh) CASE ('enthalpy ') call def_stream(nod2D, myDim_nod2D, 'enth', 'enthalpy of fusion', 'W/m^2', ice%atmcoupl%enthalpyoffuse(:), io_list(i)%freq, io_list(i)%unit, io_list(i)%precision, partit, mesh) #endif + +!------------------------------------------ +! LA 2023-01-31 adding iceberg outputs +CASE ('icb ') + if (use_icebergs) then + call def_stream(nod2D, myDim_nod2D, 'ibfwb', 'basal iceberg melting', 'm/s', ibfwb(:), 1, 'm', i_real4, partit, mesh) + call def_stream(nod2D, myDim_nod2D, 'ibfwbv', 'basal iceberg melting', 'm/s', ibfwbv(:), 1, 'm', i_real4, partit, mesh) + call def_stream(nod2D, myDim_nod2D, 'ibfwl', 'lateral iceberg melting', 'm/s', ibfwl(:), 1, 'm', i_real4, partit, mesh) + call def_stream(nod2D, myDim_nod2D, 'ibfwe', 'iceberg erosion', 'm/s', ibfwe(:), 1, 'm', i_real4, partit, mesh) + call def_stream(nod2D, myDim_nod2D, 'ibhf', 'heat flux from iceberg melting', 'm/s', ibhf(:), 1, 'm', i_real4, partit, mesh) + end if +!------------------------------------------ !_______________________________________________________________________________ ! TKE mixing diagnostic CASE ('TKE ') @@ -1166,9 +1230,10 @@ subroutine output(istep, ice, dynamics, tracers, partit, mesh) ! define output streams-->dimension, variable, long_name, units, array, freq, unit, precision !PS if (partit%flag_debug .and. partit%mype==0) print *, achar(27)//'[32m'//' -I/O-> call ini_mean_io'//achar(27)//'[0m' call ini_mean_io(ice, dynamics, tracers, partit, mesh) - + !PS if (partit%flag_debug .and. partit%mype==0) print *, achar(27)//'[33m'//' -I/O-> call init_io_gather'//achar(27)//'[0m' call init_io_gather(partit) + #if defined (__icepack) call init_io_icepack(mesh) !icapack has its copy of p_partit => partit #endif diff --git a/src/io_restart.F90 b/src/io_restart.F90 index 60819e928..6ba528f03 100644 --- a/src/io_restart.F90 +++ b/src/io_restart.F90 @@ -154,6 +154,15 @@ subroutine ini_ice_io(year, ice, partit, mesh) call ice_files%def_node_var_optional('ice_albedo', 'ice albedo', '-', ice%atmcoupl%ice_alb, mesh, partit) call ice_files%def_node_var_optional('ice_temp', 'ice surface temperature', 'K', ice%data(4)%values, mesh, partit) #endif /* (__oifs) */ +#if defined (__oasis) + !---wiso-code + if (lwiso) then + call ice_files%def_node_var_optional('h2o18_ice', 'h2o18 concentration in sea ice', 'kmol/m**3', tr_arr_ice(:,1), mesh, partit) + call ice_files%def_node_var_optional('hDo16_ice', 'hDo16 concentration in sea ice', 'kmol/m**3', tr_arr_ice(:,2), mesh, partit) + call ice_files%def_node_var_optional('h2o16_ice', 'h2o16 concentration in sea ice', 'kmol/m**3', tr_arr_ice(:,3), mesh, partit) + end if + !---wiso-code-end +#endif end subroutine ini_ice_io ! diff --git a/src/io_restart_file_group.F90 b/src/io_restart_file_group.F90 index 03a2115d6..f9e6d2b69 100644 --- a/src/io_restart_file_group.F90 +++ b/src/io_restart_file_group.F90 @@ -17,7 +17,7 @@ module restart_file_group_module type restart_file_group private - type(restart_file_type), public :: files(22) + type(restart_file_type), public :: files(32) integer, public :: nfiles = 0 ! todo: allow dynamically allocated size without messing with shallow copied pointers contains generic, public :: def_node_var => def_node_var_2d, def_node_var_3d diff --git a/src/oce_age_tracer.F90 b/src/oce_age_tracer.F90 new file mode 100755 index 000000000..cf3b12ebf --- /dev/null +++ b/src/oce_age_tracer.F90 @@ -0,0 +1,63 @@ +module age_tracer_init_interface + interface + subroutine age_tracer_init(partit, mesh) + use mod_partit + use mod_mesh + type(t_partit), intent(in), target :: partit + type(t_mesh), intent(in), target :: mesh + end subroutine + end interface +end module + +subroutine age_tracer_init(partit, mesh) + use MOD_PARTIT + use MOD_MESH + use g_comm_auto + use g_forcing_param + use g_forcing_arrays + + implicit none + + integer :: n, i, j, num_reg, num_nod, num_days + integer :: n_loc, fileID + integer, allocatable :: temp_arr2d(:), nodes_release(:) + character*300 :: file_name + type(t_partit), intent(in), target :: partit + type(t_mesh), intent(in) , target :: mesh + +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + if (use_age_mask) then + allocate(temp_arr2d(nod2D)) + temp_arr2d=0 + do n=1, myDim_nod2D !note: eDim_nod2D should not be included in this case + temp_arr2d(myList_nod2D(n))=n + end do + + file_name=trim(age_tracer_path)//'age_tracer_release_nodes.out' + fileID=160 + open(fileID, file=file_name) + read(fileID,*) num_nod + allocate(nodes_release(num_nod)) + read(fileID,*) nodes_release + close(fileID) + + do n=1,num_nod + n_loc=temp_arr2d(nodes_release(n)) + if(n_loc>0) then + age_tracer_loc_index(n_loc)=1 + end if + end do + + deallocate(nodes_release) + deallocate(temp_arr2d) + + if(mype==0) write(*,*) 'Age tracer file prepared: ', file_name + if(mype==0) write(*,*) 'index_age_tracer: ', index_age_tracer + end if + +end subroutine age_tracer_init + diff --git a/src/oce_ale.F90 b/src/oce_ale.F90 index ffc16afd9..4b3bb379b 100644 --- a/src/oce_ale.F90 +++ b/src/oce_ale.F90 @@ -175,10 +175,18 @@ subroutine init_ale(dynamics, partit, mesh) USE MOD_PARSUP USE MOD_DYN USE o_ARRAYS - USE g_config, only: which_ale, use_cavity, use_partial_cell +! USE g_config, only: which_ale, use_cavity, use_partial_cell + +! kh 18.03.21 + USE g_config, only: which_ale, use_cavity, use_partial_cell, ib_async_mode + USE g_forcing_param, only: use_virt_salt use oce_ale_interfaces Implicit NONE + +! kh 18.03.21 + integer :: i, j + type(t_dyn) , intent(inout), target :: dynamics type(t_partit), intent(inout), target :: partit type(t_mesh), intent(inout), target :: mesh @@ -213,7 +221,38 @@ subroutine init_ale(dynamics, partit, mesh) allocate(mesh%zbar_3d_n(nl,myDim_nod2D+eDim_nod2D)) ! Z_n: mid depth of layers due to ale thinkness variactions at ervery node n - allocate(mesh%Z_3d_n(nl-1,myDim_nod2D+eDim_nod2D)) +! allocate(mesh%Z_3d_n(nl-1,myDim_nod2D+eDim_nod2D)) +! kh 18.03.21 + if (ib_async_mode == 0) then + allocate(mesh%Z_3d_n(nl-1,myDim_nod2D+eDim_nod2D)) + allocate(mesh%Z_3d_n_ib(nl-1,myDim_nod2D+eDim_nod2D)) + Z_3d_n(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%Z_3d_n(:,:) + Z_3d_n_ib(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%Z_3d_n_ib(:,:) + !allocate(Z_3d_n(nl-1,myDim_nod2D+eDim_nod2D)) + !allocate(Z_3d_n_ib(nl-1,myDim_nod2D+eDim_nod2D)) + else +! kh 18.03.21 support "first touch" idea +!$omp parallel sections num_threads(2) +!$omp section + allocate(mesh%Z_3d_n(nl-1,myDim_nod2D+eDim_nod2D)) + Z_3d_n(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%Z_3d_n(:,:) + !allocate(Z_3d_n(nl-1,myDim_nod2D+eDim_nod2D)) + do i = 1, myDim_nod2D+eDim_nod2D + do j = 1, nl-1 + Z_3d_n(j, i) = 0._WP + end do + end do +!$omp section + allocate(mesh%Z_3d_n_ib(nl-1,myDim_nod2D+eDim_nod2D)) + Z_3d_n_ib(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%Z_3d_n_ib(:,:) + !allocate(Z_3d_n_ib(nl-1,myDim_nod2D+eDim_nod2D)) + do i = 1, myDim_nod2D+eDim_nod2D + do j = 1, nl-1 + Z_3d_n_ib(j, i) = 0._WP + end do + end do +!$omp end parallel sections + end if ! bottom_elem_tickness: changed bottom layer thinkness due to partial cells allocate(mesh%bottom_elem_thickness(myDim_elem2D)) @@ -231,7 +270,7 @@ subroutine init_ale(dynamics, partit, mesh) hnode(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%hnode(:,:) hnode_new(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%hnode_new(:,:) zbar_3d_n(1:mesh%nl, 1:myDim_nod2D+eDim_nod2D) => mesh%zbar_3d_n(:,:) - Z_3d_n(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%Z_3d_n(:,:) + !Z_3d_n(1:mesh%nl-1, 1:myDim_nod2D+eDim_nod2D) => mesh%Z_3d_n(:,:) helem(1:mesh%nl-1, 1:myDim_elem2D) => mesh%helem(:,:) bottom_elem_thickness(1:myDim_elem2D) => mesh%bottom_elem_thickness(:) bottom_node_thickness(1:myDim_nod2D+eDim_nod2D) => mesh%bottom_node_thickness(:) diff --git a/src/oce_ale_tracer.F90 b/src/oce_ale_tracer.F90 index 92c6ce552..511c4fa0e 100644 --- a/src/oce_ale_tracer.F90 +++ b/src/oce_ale_tracer.F90 @@ -140,7 +140,8 @@ subroutine solve_tracers_ale(ice, dynamics, tracers, partit, mesh) use o_tracers use Toy_Channel_Soufflet use diff_tracers_ale_interface - use oce_adv_tra_driver_interfaces + use oce_adv_tra_driver_interfaces + use g_forcing_param, only: use_age_tracer !---age-code implicit none type(t_ice) , intent(in) , target :: ice type(t_dyn) , intent(inout), target :: dynamics @@ -286,6 +287,20 @@ subroutine solve_tracers_ale(ice, dynamics, tracers, partit, mesh) end where end do !$OMP END PARALLEL DO + + !---age-code-begin + if (use_age_tracer) then +!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(node, nzmin, nzmax) + do node=1,myDim_nod2D+eDim_nod2D + nzmax=nlevels_nod2D(node)-1 + nzmin=ulevels_nod2D(node) + where (tracers%data(index_age_tracer)%values(nzmin:nzmax,node) < 0._WP ) + tracers%data(index_age_tracer)%values(nzmin:nzmax,node) = 0._WP + end where + end do +!$OMP END PARALLEL DO + end if + !---age-code-end end subroutine solve_tracers_ale ! ! @@ -1312,8 +1327,19 @@ FUNCTION bc_surface(n, id, sval, nzmin, partit) ! by forming/melting of sea ice bc_surface= dt*(virtual_salt(n) & !--> is zeros for zlevel/zstar + relax_salt(n) - real_salt_flux(n)*is_nonlinfs) - CASE (101) ! apply boundary conditions to tracer ID=101 - bc_surface= dt*(prec_rain(n))! - real_salt_flux(n)*is_nonlinfs) +!---wiso-code + CASE (101) ! apply boundary conditions to tracer ID=101 (H218O) + bc_surface = dt*wiso_flux_oce(n,1) + CASE (102) ! apply boundary conditions to tracer ID=102 (HDO) + bc_surface = dt*wiso_flux_oce(n,2) + CASE (103) ! apply boundary conditions to tracer ID=103 (H216O) + bc_surface = dt*wiso_flux_oce(n,3) +!---wiso-code-end +!---age-code + CASE (100) + !bc_surface=-dt*(sval*water_flux(n)*is_nonlinfs) + bc_surface=0.0_WP +!---age-code-end CASE (301) bc_surface=0.0_WP CASE (302) diff --git a/src/oce_landice_water.F90 b/src/oce_landice_water.F90 new file mode 100644 index 000000000..db87063e2 --- /dev/null +++ b/src/oce_landice_water.F90 @@ -0,0 +1,88 @@ +module landice_water_init_interface + interface + subroutine landice_water_init(partit, mesh) + use mod_partit + use mod_mesh + type(t_partit), intent(in), target :: partit + type(t_mesh), intent(in), target :: mesh + end subroutine + end interface +end module + +subroutine landice_water_init(partit, mesh) + ! init land ice melting rate + use MOD_PARTIT + use MOD_MESH + use o_PARAM , only: WP + use g_comm_auto + use g_forcing_param + use g_forcing_arrays + + implicit none + + integer :: n, i, j, num_reg, num_nod, num_days + integer :: n_loc, fileID + integer, allocatable :: temp_arr2d(:), nodes_in_region(:) + real(kind=WP) :: vol, vol_sum, aux + real(kind=WP), allocatable :: totalflux(:) + character*300 :: file_name + character :: c_reg_ind + type(t_partit), intent(in), target :: partit + type(t_mesh), intent(in), target :: mesh +#include "associate_part_def.h" +#include "associate_mesh_def.h" +#include "associate_part_ass.h" +#include "associate_mesh_ass.h" + + ! read the number of region and the total yearly discharge in each region: + file_name=trim(fwf_path)//'landice_yearly_mass_loss.out' + fileID=160 + open(fileID, file=file_name) + read(fileID,*) num_reg + allocate(totalflux(num_reg)) + read(fileID,*) totalflux !Surface Flux (m/s) = water flux (Sv)*1e6/area_sum + close(fileID) + + + allocate(temp_arr2d(nod2D)) + temp_arr2d=0 + do n=1, myDim_nod2D !note: eDim_nod2D should not be included in this case + temp_arr2d(myList_nod2D(n))=n + end do + + do i=1,num_reg + + !read in nodes in the region + write(c_reg_ind,'(i1)') i !assume that num_reg is less than 10 + file_name=trim(fwf_path)//'landice_nodes_in_region_'//c_reg_ind//'.out' + fileID=160 + open(fileID, file=file_name) + read(fileID,*) num_nod + allocate(nodes_in_region(num_nod)) + read(fileID,*) nodes_in_region + close(fileID) + + + aux=totalflux(i) !m/s + + do n=1,num_nod + n_loc=temp_arr2d(nodes_in_region(n)) + if(n_loc>0) then + runoff_landice(n_loc)=aux + end if + end do + + deallocate(nodes_in_region) + end do + + landice_season=0.0 + landice_season(landice_start_mon:landice_end_mon)=1.0 + + deallocate(temp_arr2d, totalflux) + + if(mype==0) write(*,*) 'Land-ice melt water fluxes prepared.' + if(mype==0) write(*,*) 'freshwater flux (m/s)=', aux + if(mype==0) write(*,*) 'landice_season=', landice_season + +end subroutine landice_water_init + diff --git a/src/oce_modules.F90 b/src/oce_modules.F90 index 8805165b2..184c9d4f2 100755 --- a/src/oce_modules.F90 +++ b/src/oce_modules.F90 @@ -89,6 +89,14 @@ MODULE o_PARAM allocatable, dimension(:) :: ptracers_restore integer :: ptracers_restore_total=0 +!---wiso-code +! add water isotope parameters +real(kind=WP), dimension(3) :: wiso_smow = (/2005.2e-6_WP, 155.76e-6_WP, 1.0_WP/) ! water isotope SMOW values +integer, dimension(3) :: index_wiso_tracers = (/-1, -1, -1/) ! water isotope index in all tracers +!---wiso-code-end +!---age-code-begin +integer :: index_age_tracer = -1 ! water age tracer index in all tracers +!---age-code-end ! Momentum !!PS logical :: free_slip=.false. @@ -176,6 +184,7 @@ MODULE o_ARRAYS ! Arrays are described in subroutine array_setup real(kind=WP), allocatable :: uke(:,:), v_back(:,:), uke_back(:,:), uke_dis(:,:), uke_dif(:,:) real(kind=WP), allocatable :: uke_rhs(:,:), uke_rhs_old(:,:) +!real(kind=WP), allocatable :: UV_ib(:,:,:) ! kh 08.03.21 additional array for asynchronous iceberg computations real(kind=WP), allocatable :: UV_dis_tend(:,:,:), UV_back_tend(:,:,:), UV_total_tend(:,:,:), UV_dis_tend_node(:,:,:) real(kind=WP), allocatable :: UV_dis_posdef_b2(:,:), UV_dis_posdef(:,:), UV_back_posdef(:,:) real(kind=WP), allocatable :: hpressure(:,:) @@ -183,11 +192,18 @@ MODULE o_ARRAYS real(kind=WP), allocatable :: stress_node_surf(:,:) REAL(kind=WP), ALLOCATABLE :: stress_atmoce_x(:) REAL(kind=WP), ALLOCATABLE :: stress_atmoce_y(:) -real(kind=WP), allocatable :: heat_flux(:), Tsurf(:) -real(kind=WP), allocatable :: heat_flux_in(:) !to keep the unmodified (by SW penetration etc.) heat flux +real(kind=WP), allocatable :: heat_flux(:), Tsurf(:) +real(kind=WP), allocatable :: heat_flux_in(:) !to keep the unmodified (by SW penetration etc.) heat flux +real(kind=WP), allocatable :: Tsurf_ib(:) ! kh 15.03.21 additional array for asynchronous iceberg computations real(kind=WP), allocatable :: water_flux(:), Ssurf(:) +real(kind=WP), allocatable :: Ssurf_ib(:) ! kh 15.03.21 additional array for asynchronous iceberg computations real(kind=WP), allocatable :: virtual_salt(:), relax_salt(:) real(kind=WP), allocatable :: Tclim(:,:), Sclim(:,:) + +!-------------- +! LA: add iceberg tracer arrays 2023-02-08 +!-------------- +real(kind=WP), allocatable :: Tclim_ib(:,:), Sclim_ib(:,:) !!PS real(kind=WP), allocatable :: Visc(:,:) real(kind=WP), allocatable :: Tsurf_t(:,:), Ssurf_t(:,:) real(kind=WP), allocatable :: tau_x_t(:,:), tau_y_t(:,:) @@ -245,5 +261,12 @@ MODULE o_ARRAYS real(kind=WP), target, allocatable :: fer_c(:), fer_scal(:), fer_K(:,:), fer_gamma(:,:,:) real(kind=WP), allocatable :: ice_rejected_salt(:) + +!---wiso-code +real(kind=WP), allocatable :: tr_arr_ice(:,:) !---wiso-code: add sea ice isotope tracers +real(kind=WP), allocatable :: wiso_flux_oce(:,:) !---wiso-code: add isotope fluxes over open water +real(kind=WP), allocatable :: wiso_flux_ice(:,:) !---wiso-code: add isotope fluxes over sea ice +!---wiso-code-end + END MODULE o_ARRAYS !========================================================== diff --git a/src/oce_setup_step.F90 b/src/oce_setup_step.F90 index 8a57e0960..2b2f59f0d 100755 --- a/src/oce_setup_step.F90 +++ b/src/oce_setup_step.F90 @@ -275,6 +275,8 @@ SUBROUTINE tracer_init(tracers, partit, mesh) USE MOD_TRACER USE DIAGNOSTICS, only: ldiag_DVD USE g_ic3d + use g_forcing_param, only: use_age_tracer !---age-code + use g_config, only : lwiso ! add lwiso switch IMPLICIT NONE type(t_tracer), intent(inout), target :: tracers type(t_partit), intent(inout), target :: partit @@ -327,6 +329,50 @@ SUBROUTINE tracer_init(tracers, partit, mesh) end if end do + !---wiso-code + !===================== + ! set necessary water isotope variables + !===================== + IF (lwiso) THEN + ! always assume 3 water isotope tracers in the order H218O, HD16O, H216O + ! tracers simulated in the model + nml_tracer_list(num_tracers+1) = nml_tracer_list(1) ! use the same scheme as temperature + nml_tracer_list(num_tracers+2) = nml_tracer_list(1) + nml_tracer_list(num_tracers+3) = nml_tracer_list(1) + + nml_tracer_list(num_tracers+1)%id = 101 + nml_tracer_list(num_tracers+2)%id = 102 + nml_tracer_list(num_tracers+3)%id = 103 + + index_wiso_tracers(1) = num_tracers+1 + index_wiso_tracers(2) = num_tracers+2 + index_wiso_tracers(3) = num_tracers+3 + + num_tracers = num_tracers + 3 + + ! tracers initialised from file + idlist((n_ic3d+1):(n_ic3d+3)) = (/101, 102, 103/) + filelist((n_ic3d+1):(n_ic3d+3)) = (/'wiso.nc', 'wiso.nc', 'wiso.nc'/) + varlist((n_ic3d+1):(n_ic3d+3)) = (/'h2o18', 'hDo16', 'h2o16'/) + + n_ic3d = n_ic3d + 3 + + if (mype==0) write(*,*) '3 water isotope tracers will be used in FESOM' + END IF + !---wiso-code-end + + !---age-code-begin + if (use_age_tracer) then + ! add age tracer in the model + nml_tracer_list(num_tracers+1) = nml_tracer_list(1) + nml_tracer_list(num_tracers+1)%id = 100 + index_age_tracer = num_tracers+1 + num_tracers = num_tracers + 1 + + if (mype==0) write(*,*) '1 water age tracer will be used in FESOM' + endif + !---age-code-end + if (mype==0) write(*,*) 'total number of tracers is: ', num_tracers !___________________________________________________________________________ @@ -587,7 +633,7 @@ SUBROUTINE arrays_init(num_tracers, partit, mesh) type(t_mesh), intent(in), target :: mesh !___________________________________________________________________________ integer :: elem_size, node_size - integer :: n + integer :: n, nt !___________________________________________________________________________ ! define dynamics namelist parameter #include "associate_part_def.h" @@ -622,6 +668,10 @@ SUBROUTINE arrays_init(num_tracers, partit, mesh) ! Ocean forcing arrays ! ================ allocate(Tclim(nl-1,node_size), Sclim(nl-1, node_size)) + !--- + ! LA: add iceberg tracers 2023-02-08 + allocate(Tclim_ib(nl-1,node_size), Sclim_ib(nl-1, node_size)) + !--- allocate(stress_surf(2,myDim_elem2D)) !!! Attention, it is shorter !!! allocate(stress_node_surf(2,node_size)) allocate(stress_atmoce_x(node_size), stress_atmoce_y(node_size)) @@ -633,6 +683,7 @@ SUBROUTINE arrays_init(num_tracers, partit, mesh) allocate(heat_flux_in(node_size)) allocate(real_salt_flux(node_size)) !PS + ! ================= ! Arrays used to organize surface forcing ! ================= @@ -765,6 +816,25 @@ SUBROUTINE arrays_init(num_tracers, partit, mesh) !!PS dum_2d_e = 0.0_WP !!PS dum_3d_e = 0.0_WP + !---wiso-code + if (lwiso) then + allocate(tr_arr_ice(node_size,3)) ! add sea ice tracers + allocate(wiso_flux_oce(node_size,3)) + allocate(wiso_flux_ice(node_size,3)) + + ! initialize sea ice isotopes with 0. permill + ! absolute tracer values are increased by factor 1000. for numerical reasons + ! (see also routine oce_fluxes in ice_oce_coupling.F90) + do nt = 1,3 + tr_arr_ice(:,nt)=wiso_smow(nt) * 1000.0_WP + end do + + ! initialize atmospheric fluxes over open ocean and sea ice + wiso_flux_oce=0.0_WP + wiso_flux_ice=0.0_WP + end if + !---wiso-code-end + END SUBROUTINE arrays_init ! ! @@ -809,6 +879,13 @@ SUBROUTINE oce_initial_state(tracers, partit, mesh) Sclim=tracers%data(2)%values Tsurf=Tclim(1,:) Ssurf=Sclim(1,:) + + if (use_icebergs) then + Tclim_ib=tracers%data(1)%values + Sclim_ib=tracers%data(2)%values + Tsurf_ib=Tclim(1,:) + Ssurf_ib=Sclim(1,:) + end if relax2clim=0.0_WP ! count the passive tracers which require 3D source (ptracers_restore_total) @@ -831,15 +908,41 @@ SUBROUTINE oce_initial_state(tracers, partit, mesh) DO i=3, tracers%num_tracers id=tracers%data(i)%ID SELECT CASE (id) - !_______________________________________________________________________ - CASE (101) ! initialize tracer ID=101 - tracers%data(i)%values(:,:)=0.0_WP - if (mype==0) then - write (i_string, "(I3)") i - write (id_string, "(I3)") id - write(*,*) 'initializing '//trim(i_string)//'th tracer with ID='//trim(id_string) - end if - + !---age-code-begin + ! FESOM tracers with code id 100 are used as water age + CASE (100) + if (mype==0) then + write (i_string, "(I3)") i + write (id_string, "(I3)") id + write(*,*) 'initializing '//trim(i_string)//'th tracer with ID='//trim(id_string) + write (*,*) tracers%data(i)%values(1,1) + end if + !---age-code-end + !---wiso-code + ! FESOM tracers with code id 101, 102, 103 are used as water isotopes + CASE (101) ! initialize tracer ID=101 H218O + if (mype==0) then + write (i_string, "(I3)") i + write (id_string, "(I3)") id + write(*,*) 'initializing '//trim(i_string)//'th tracer with ID='//trim(id_string) + write (*,*) tracers%data(i)%values(1,1) + end if + CASE (102) ! initialize tracer ID=102 HD16O + if (mype==0) then + write (i_string, "(I3)") i + write (id_string, "(I3)") id + write(*,*) 'initializing '//trim(i_string)//'th tracer with ID='//trim(id_string) + write (*,*) tracers%data(i)%values(1,1) + end if + CASE (103) ! initialize tracer ID=103 H216O + if (mype==0) then + write (i_string, "(I3)") i + write (id_string, "(I3)") id + write(*,*) 'initializing '//trim(i_string)//'th tracer with ID='//trim(id_string) + write (*,*) tracers%data(i)%values(1,1) + end if + !---wiso-code-end + !_______________________________________________________________________ CASE (301) !Fram Strait 3d restored passive tracer tracers%data(i)%values(:,:)=0.0_WP